summaryrefslogtreecommitdiff
path: root/fig-emulator-gb/src
diff options
context:
space:
mode:
Diffstat (limited to 'fig-emulator-gb/src')
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB.hs83
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs65
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs4
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs8
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs146
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs8
6 files changed, 232 insertions, 82 deletions
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB.hs b/fig-emulator-gb/src/Fig/Emulator/GB.hs
index d5ae4e7..76e6c85 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB.hs
@@ -1,8 +1,6 @@
-{-# Language ImplicitParams #-}
module Fig.Emulator.GB where
import Fig.Prelude
-import Prelude (fromIntegral)
import System.IO (withFile, IOMode (WriteMode))
@@ -21,8 +19,8 @@ import Fig.Emulator.GB.Component.Video
import Fig.Emulator.GB.Component.Joystick
import Fig.Emulator.GB.Component.Serial
-cpuDMG :: (MonadIO m, MonadThrow m) => ByteString -> Framebuffer -> CPU m
-cpuDMG rom fb = CPU
+cpuDMG :: (MonadIO m, MonadThrow m) => Handle -> ByteString -> Framebuffer -> CPU m
+cpuDMG h rom fb = CPU
{ _lastPC = 0x0
, _lastIns = Nop
, _running = True
@@ -32,52 +30,49 @@ cpuDMG rom fb = CPU
, compWRAM 0xc000 $ 8 * 1024
, compVideo fb
, compJoystick
- , compSerial
+ , compSerial h
, compWRAM 0xff80 0x7e -- HRAM
]
}
-testRun :: forall m. (MonadIO m, MonadThrow m) => ByteString -> m ()
-testRun rom = do
+testRun :: forall m. (MonadIO m, MonadThrow m) => FilePath -> ByteString -> m ()
+testRun serialOut rom = do
SDL.initializeAll
window <- SDL.createWindow "taking" SDL.defaultWindow
fb <- initializeFramebuffer
- let cpu = cpuDMG rom fb
- let
- loop :: forall m'. Emulating m' => Int -> m' ()
- loop cycle = do
- 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
- log $ mconcat
- [ pretty $ Addr pc
- , ": ", tshow ins
- ]
- step ins
- -- logCPUState
- 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
- r <- use running
- when r . loop $ cycle + 1
- liftIO $ withFile "log.txt" WriteMode \h -> do
- let ?log = h
+ liftIO $ withFile serialOut WriteMode \hserial -> do
+ let cpu = cpuDMG hserial rom fb
+ let
+ loop :: forall m'. Emulating m' => Int -> m' ()
+ loop cycle = do
+ 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
+ log $ mconcat
+ [ pretty $ Addr pc
+ , ": ", tshow ins
+ ]
+ step ins
+ 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
+ r <- use running
+ when r . loop $ cycle + 1
void $ flip runStateT cpu do
- -- logCPUState
loop 0
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
index 40fd6c8..002bde5 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
@@ -1,27 +1,26 @@
-{-# Language TemplateHaskell, ImplicitParams #-}
+{-# Language TemplateHaskell #-}
module Fig.Emulator.GB.CPU
( CPU(..)
, Registers(..), initialRegs
, Emulating
- , running, regs, bus, regPC
+ , running, regs, bus, regPC, regSP
+ , regA, regB, regC, regD, regE, regH, regL
+ , regFlagZ, regFlagN, regFlagH, regFlagC
, updateComps
, decode
, step
- , logCPUState
) where
import Control.Lens.TH (makeLenses)
-import Data.Maybe (fromJust)
-
import Fig.Prelude
-import Prelude (fromIntegral)
import qualified Text.Printf as Pr
import Control.Lens ((.=), use, (^.))
import Control.Monad (when)
+import Data.Maybe (fromJust)
import Data.Word (Word8, Word16)
import Data.Int (Int8)
import Data.Bits
@@ -75,34 +74,34 @@ data CPU m = CPU
}
makeLenses 'CPU
-type EmulatingT f m = (MonadIO m, MonadThrow m, MonadState (CPU f) m, ?log :: Handle)
+type EmulatingT f m = (MonadIO m, MonadThrow m, MonadState (CPU f) m)
type Emulating m = EmulatingT IO m
-logCPUState :: Emulating m => m ()
-logCPUState = do
- rs <- use regs
- let pc = rs ^. regPC
- b <- use bus
- m0 <- fromJust <$> liftIO (Bus.read b $ Addr pc)
- m1 <- fromJust <$> liftIO (Bus.read b $ Addr pc + 1)
- m2 <- fromJust <$> liftIO (Bus.read b $ Addr pc + 2)
- m3 <- fromJust <$> liftIO (Bus.read b $ 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"
+-- logCPUState :: Emulating m => m ()
+-- logCPUState = do
+-- rs <- use regs
+-- let pc = rs ^. regPC
+-- b <- use bus
+-- m0 <- fromJust <$> liftIO (Bus.read b $ Addr pc)
+-- m1 <- fromJust <$> liftIO (Bus.read b $ Addr pc + 1)
+-- m2 <- fromJust <$> liftIO (Bus.read b $ Addr pc + 2)
+-- m3 <- fromJust <$> liftIO (Bus.read b $ 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"
updateComps :: Emulating m => Int -> m ()
updateComps t = do
@@ -289,7 +288,7 @@ step ins = do
res = x + y
regs . regFlagH .= (shiftR res 11 .&. 0b1 == 0b1)
regs . regFlagC .= (shiftR res 15 .&. 0b1 == 0b1)
- regs . regFlagZ .= (res .&. 0xffff == 0)
+ regs . regFlagZ .= (res == 0)
regs . regFlagN .= False
setR16 R16HL res
IncR8 r -> do
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
index f5c08b4..e20dd8d 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
@@ -24,7 +24,7 @@ compWRAM :: (MonadIO m, MonadThrow m) => Addr -> Int -> Component m
compWRAM start size = Component
{ compState = V.replicate size 0 :: V.Vector Word8
, compMatches = \a ->
- a >= start && a < end
+ a >= start && a <= end
, compUpdate = \s _ -> pure s
, compWrite = \s ad v -> do
let offset = fromIntegral . unAddr $ ad - start
@@ -38,4 +38,4 @@ compWRAM start size = Component
Just v -> pure v
}
where
- end = start + Addr (fromIntegral size)
+ end = start + Addr (fromIntegral (size - 1))
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 68bc477..59200f1 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs
@@ -1,7 +1,8 @@
module Fig.Emulator.GB.Component.Serial where
import Fig.Prelude
-import Prelude (fromIntegral)
+
+import GHC.IO.Handle (hPutChar)
import Data.Char (chr)
@@ -17,8 +18,8 @@ instance Pretty SerialError where
, b
]
-compSerial :: (MonadIO m, MonadThrow m) => Component m
-compSerial = Component
+compSerial :: (MonadIO m, MonadThrow m) => Handle -> Component m
+compSerial h = Component
{ compState = ()
, compMatches = (== 0xff01)
, compUpdate = \s _ -> pure s
@@ -26,6 +27,7 @@ compSerial = Component
log $ mconcat
[ "wrote serial byte: ", tshow $ chr $ fromIntegral v
]
+ liftIO . hPutChar h . chr $ fromIntegral v
pure s
, compRead = \_ _ -> pure 0x00
}
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs
new file mode 100644
index 0000000..1a9c015
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs
@@ -0,0 +1,146 @@
+{-# Language TemplateHaskell, ApplicativeDo #-}
+module Fig.Emulator.GB.Test.Instr where
+
+import Control.Lens.TH (makeLenses)
+
+import Control.Lens ((^.))
+import Control.Monad.State (StateT(..))
+
+import Data.Word (Word8, Word16)
+import qualified Data.Aeson as Aeson
+
+import Fig.Prelude
+import Fig.Emulator.GB.Utils
+import Fig.Emulator.GB.CPU
+import Fig.Emulator.GB.CPU.Instruction
+import Fig.Emulator.GB.Bus (Bus(..), Addr(..))
+import qualified Fig.Emulator.GB.Bus as Bus
+import Fig.Emulator.GB.Component.RAM
+
+newtype InstrTestError = InstrTestError Text
+ deriving Show
+instance Exception InstrTestError
+instance Pretty InstrTestError where
+ pretty (InstrTestError b) = mconcat
+ [ "Instruction test error: "
+ , b
+ ]
+
+data TestVals = TestVals
+ { _testvalsA :: !Word8
+ , _testvalsB :: !Word8
+ , _testvalsC :: !Word8
+ , _testvalsD :: !Word8
+ , _testvalsE :: !Word8
+ , _testvalsF :: !Word8
+ , _testvalsH :: !Word8
+ , _testvalsL :: !Word8
+ , _testvalsPC :: !Word16
+ , _testvalsSP :: !Word16
+ , _testvalsRAM :: ![(Word16, Word8)]
+ }
+makeLenses 'TestVals
+instance Aeson.FromJSON TestVals where
+ parseJSON = Aeson.withObject "TestVals" $ \v -> do
+ _testvalsA <- v Aeson..: "a"
+ _testvalsB <- v Aeson..: "b"
+ _testvalsC <- v Aeson..: "c"
+ _testvalsD <- v Aeson..: "d"
+ _testvalsE <- v Aeson..: "e"
+ _testvalsF <- v Aeson..: "f"
+ _testvalsH <- v Aeson..: "h"
+ _testvalsL <- v Aeson..: "l"
+ _testvalsPC <- v Aeson..: "pc"
+ _testvalsSP <- v Aeson..: "sp"
+ _testvalsRAM <- v Aeson..: "ram"
+ pure TestVals{..}
+
+data Testcase = Testcase
+ { _testcaseName :: !Text
+ , _testcaseInitial :: !TestVals
+ , _testcaseFinal :: !TestVals
+ }
+makeLenses 'Testcase
+
+instance Aeson.FromJSON Testcase where
+ parseJSON = Aeson.withObject "Testcase" $ \v -> do
+ _testcaseName <- v Aeson..: "name"
+ _testcaseInitial <- v Aeson..: "initial"
+ _testcaseFinal <- v Aeson..: "final"
+ pure Testcase {..}
+
+readTestcases :: (MonadIO m, MonadThrow m) => FilePath -> m [Testcase]
+readTestcases p = liftIO (Aeson.decodeFileStrict p) >>= \case
+ Just ts -> pure ts
+ Nothing -> throwM . InstrTestError $ "failed to read testcases at " <> pack p
+
+cpuInstrTest :: (MonadIO m, MonadThrow m) => TestVals -> m (CPU m)
+cpuInstrTest vs = do
+ let
+ (z, n, h, c) = w8flags $ vs ^. testvalsF
+ initialBus = Bus [compWRAM 0x0000 $ 64 * 1024]
+ finalBus <- foldM (\b (addr, v) -> Bus.write b (Addr addr) v) initialBus $ vs ^. testvalsRAM
+ pure CPU
+ { _lastPC = 0x0
+ , _lastIns = Nop
+ , _running = True
+ , _regs = initialRegs
+ { _regA = vs ^. testvalsA
+ , _regB = vs ^. testvalsB
+ , _regC = vs ^. testvalsC
+ , _regD = vs ^. testvalsD
+ , _regE = vs ^. testvalsE
+ , _regH = vs ^. testvalsH
+ , _regL = vs ^. testvalsL
+ , _regPC = vs ^. testvalsPC - 1
+ , _regSP = vs ^. testvalsSP
+ , _regFlagZ = z
+ , _regFlagN = n
+ , _regFlagH = h
+ , _regFlagC = c
+ }
+ , _bus = finalBus
+ }
+
+checkCPU :: forall m. (MonadIO m, MonadThrow m) => Text -> TestVals -> CPU m -> m ()
+checkCPU tnm vs c = do
+ let
+ check :: (Eq a, Show a) => Text -> a -> a -> m ()
+ check nm eval aval = if eval == aval
+ then pure ()
+ else throwM . InstrTestError $ mconcat
+ [ "while running test ", tnm, ":\n"
+ , nm <> " mismatch: expected "
+ , tshow eval, ", got ", tshow aval
+ ]
+ check "register A" (vs ^. testvalsA) (c ^. regs . regA)
+ check "register B" (vs ^. testvalsB) (c ^. regs . regB)
+ check "register C" (vs ^. testvalsC) (c ^. regs . regC)
+ check "register D" (vs ^. testvalsD) (c ^. regs . regD)
+ check "register E" (vs ^. testvalsE) (c ^. regs . regE)
+ check "register H" (vs ^. testvalsH) (c ^. regs . regH)
+ check "register L" (vs ^. testvalsL) (c ^. regs . regL)
+ check "PC" (vs ^. testvalsPC - 1) (c ^. regs . regPC)
+ check "SP" (vs ^. testvalsSP) (c ^. regs . regSP)
+ let (fz, fn, fh, fc) = w8flags $ vs ^. testvalsF
+ check "flag Z" fz (c ^. regs . regFlagZ)
+ check "flag N" fn (c ^. regs . regFlagN)
+ check "flag H" fh (c ^. regs . regFlagH)
+ check "flag C" fc (c ^. regs . regFlagC)
+ forM_ (vs ^. testvalsRAM) \(Addr -> addr, eval) -> do
+ Bus.read (c ^. bus) addr >>= \case
+ Nothing -> throwM . InstrTestError $ "failed to read expected address: " <> pretty addr
+ Just aval -> check ("memory address " <> pretty addr) eval aval
+
+runTestcase :: (MonadIO m, MonadThrow m) => Testcase -> m ()
+runTestcase tc = liftIO do
+ initial <- cpuInstrTest $ tc ^. testcaseInitial
+ let
+ body :: forall m'. Emulating m' => m' Instruction
+ body = do
+ ins <- decode
+ step ins
+ pure ins
+ (ins, final) <- runStateT body initial
+ checkCPU (tc ^. testcaseName <> " (" <> tshow ins <> ")") (tc ^. testcaseFinal) final
+ log $ "Passed: " <> tc ^. testcaseName
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs
index 4d00743..b250068 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs
@@ -44,6 +44,14 @@ flagsw8 z n h c =
.|. shiftL (if h then 1 else 0) 5
.|. shiftL (if c then 1 else 0) 4
+w8flags :: Word8 -> (Bool, Bool, Bool, Bool)
+w8flags x = (z, n, h, c)
+ where
+ z = w8bit 7 x
+ n = w8bit 6 x
+ h = w8bit 5 x
+ c = w8bit 4 x
+
zext :: Word8 -> Word16
zext = fromIntegral
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 09:05:36 +0000