Automated instruction testing using linked repo

https://github.com/adtennant/GameboyCPUTests

8 files changed, 275 insertions, 90 deletions

diff --git a/fig-emulator-gb/fig-emulator-gb.cabal b/fig-emulator-gb/fig-emulator-gb.cabal
index 03dbb2e..35566dd 100644
--- a/fig-emulator-gb/fig-emulator-gb.cabal
+++ b/fig-emulator-gb/fig-emulator-gb.cabal
@@ -51,6 +51,7 @@ library
     Fig.Emulator.GB.Component.Video
     Fig.Emulator.GB.Component.Joystick
     Fig.Emulator.GB.Component.Serial
+    Fig.Emulator.GB.Test.Instr
 
 executable fig-emulator-gb
   import: defaults
diff --git a/fig-emulator-gb/main/Main.hs b/fig-emulator-gb/main/Main.hs
index 552f2ed..8cb61d0 100644
--- a/fig-emulator-gb/main/Main.hs
+++ b/fig-emulator-gb/main/Main.hs
@@ -6,24 +6,58 @@ import Fig.Prelude
 
 import Options.Applicative
 
+import Control.Exception.Safe (Handler(..), catches)
+
 import qualified Data.ByteString as BS
 
 import Fig.Emulator.GB
+import Fig.Emulator.GB.Test.Instr
 
-newtype Options = Options
-  { romPath :: FilePath
+data RunOptions = RunOptions
+  { romPath :: !FilePath
+  , serialOut :: !FilePath
   } deriving Show
 
-parseOptions :: Parser Options
-parseOptions = do
+parseRunOptions :: Parser RunOptions
+parseRunOptions = do
   romPath <- argument str (metavar "PATH")
-  pure Options{..}
+  serialOut <- strOption (long "serial" <> metavar "PATH" <> help "Path to write link cable serial output")
+  pure RunOptions{..}
+
+newtype InstrTestOptions = InstrTestOptions
+  { testcasesPath :: FilePath
+  } deriving Show
+
+parseInstrTestOptions :: Parser InstrTestOptions
+parseInstrTestOptions = do
+  testcasesPath <- argument str (metavar "PATH")
+  pure InstrTestOptions{..}
+
+data Command
+  = CommandRun RunOptions
+  | CommandInstrTest InstrTestOptions
+  deriving Show
+
+parseOptions :: Parser Command
+parseOptions = subparser $ mconcat
+  [ command "run" $ info (CommandRun <$> parseRunOptions) (progDesc "Emulate a ROM file")
+  , command "instr-test" $ info (CommandInstrTest <$> parseInstrTestOptions) (progDesc "Run CPU testcases")
+  ]
 
 main :: IO ()
 main = do
-  opts <- execParser $ info (parseOptions <**> helper)
+  cmd <- execParser $ info (parseOptions <**> helper)
     ( fullDesc
     <> header "fig-emulator-gb - Game Boy emulator"
     )
-  rom <- BS.readFile $ romPath opts
-  testRun rom
+  case cmd of
+    CommandRun opts -> do
+      rom <- BS.readFile $ romPath opts
+      testRun (serialOut opts) rom
+    CommandInstrTest opts -> catches
+      ( do
+          tcs <- readTestcases $ testcasesPath opts
+          forM_ tcs runTestcase
+      )
+      [ Handler \(e :: InstrTestError) -> liftIO . hPutStrLn stderr $ pretty e
+      ]
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