summaryrefslogtreecommitdiff
path: root/fig-emulator-gb/src/Fig/Emulator/GB
diff options
context:
space:
mode:
Diffstat (limited to 'fig-emulator-gb/src/Fig/Emulator/GB')
-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
5 files changed, 193 insertions, 38 deletions
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 11:11:38 +0000