diff options
Diffstat (limited to 'fig-emulator-gb/src/Fig/Emulator/GB/Test')
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs | 176 |
1 files changed, 0 insertions, 176 deletions
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs deleted file mode 100644 index 647e03a..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# Language TemplateHaskell, ApplicativeDo #-} -module Fig.Emulator.GB.Test.Instr where - -import Control.Lens.TH (makeLenses) - -import Control.Lens ((^.)) -import Control.Monad.State.Strict (StateT(..)) - -import Data.Word (Word8, Word16) -import qualified Data.Vector as V -import qualified Data.Aeson as Aeson - -import qualified Text.Printf as Pr - -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 :: FilePath -> IO [Testcase] -readTestcases p = liftIO (Aeson.decodeFileStrict p) >>= \case - Just ts -> pure ts - Nothing -> throwM . InstrTestError $ "failed to read testcases at " <> pack p - -cpuInstrTest :: TestVals -> IO CPU -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 :: Text -> TestVals -> CPU -> CPU -> IO () -checkCPU tnm vs initial c = do - let - flag f = if f then "1" else "0" - rreg8 = pack . Pr.printf "%02X" - rreg16 = pack . Pr.printf "%04X" - dumpRegs :: Text -> Registers -> Text - dumpRegs prefix r = mconcat - [ prefix, " registers:\t" - , "A: ", rreg8 $ r ^. regA - , ", B: ", rreg8 $ r ^. regB - , ", C: ", rreg8 $ r ^. regC - , ", D: ", rreg8 $ r ^. regD - , ", E: ", rreg8 $ r ^. regE - , ", H: ", rreg8 $ r ^. regH - , ", L: ", rreg8 $ r ^. regL - , ", PC: ", rreg16 $ r ^. regPC - , ", SP: ", rreg16 $ r ^. regSP - ] - dumpFlags :: Text -> Registers -> Text - dumpFlags prefix r = mconcat - [ prefix, " flags:\t" - , "Z: ", flag $ r ^. regFlagZ - , ", N: ", flag $ r ^. regFlagN - , ", H: ", flag $ r ^. regFlagH - , ", C: ", flag $ r ^. regFlagC - ] - check :: (Eq a) => (a -> Text) -> Text -> a -> a -> IO () - check pr nm eval aval = if eval == aval - then pure () - else throwM . InstrTestError $ mconcat - [ "while running test ", tnm, ":\n" - , nm <> " mismatch: expected " - , pr eval, ", got ", pr aval - , "\n", dumpRegs "Initial" $ initial ^. regs - , "\n", dumpRegs "Final" $ c ^. regs - , "\n", dumpFlags "Initial" $ initial ^. regs - , "\n", dumpFlags "Final" $ c ^. regs - ] - check rreg8 "register A" (vs ^. testvalsA) (c ^. regs . regA) - check rreg8 "register B" (vs ^. testvalsB) (c ^. regs . regB) - check rreg8 "register C" (vs ^. testvalsC) (c ^. regs . regC) - check rreg8 "register D" (vs ^. testvalsD) (c ^. regs . regD) - check rreg8 "register E" (vs ^. testvalsE) (c ^. regs . regE) - check rreg8 "register H" (vs ^. testvalsH) (c ^. regs . regH) - check rreg8 "register L" (vs ^. testvalsL) (c ^. regs . regL) - check rreg16 "PC" (vs ^. testvalsPC - 1) (c ^. regs . regPC) - check rreg16 "SP" (vs ^. testvalsSP) (c ^. regs . regSP) - let (fz, fn, fh, fc) = w8flags $ vs ^. testvalsF - check flag "flag Z" fz (c ^. regs . regFlagZ) - check flag "flag N" fn (c ^. regs . regFlagN) - check flag "flag H" fh (c ^. regs . regFlagH) - check flag "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 rreg8 ("memory address " <> pretty addr) eval aval - -runTestcase :: Testcase -> IO () -runTestcase tc = liftIO do - initial <- cpuInstrTest $ tc ^. testcaseInitial - let - body :: Emulating Instruction - body = do - ins <- decode - step ins - pure ins - (ins, final) <- runStateT (runEmulating body) initial - checkCPU (tc ^. testcaseName <> " (" <> tshow ins <> ")") (tc ^. testcaseFinal) initial final |