Automated ROM testing

core/src/Machine/GBC/Emulator.hs

@@ -171,6 +171,7 @@ updateHardware :: Int -> Int -> ReaderT EmulatorState IO Graphics.BusEvent
 updateHardware cycles cpuClocks = do
   EmulatorState {..} <- ask
   liftIO $ do
+    Serial.update serialState cycles
     Timer.update timerState cycles
     Audio.step audioState cpuClocks
     Graphics.step graphicsState graphicsSync cpuClocks

core/src/Machine/GBC/Serial.hs

@@ -85,8 +85,8 @@ notifyIncoming State {..} period incomingValue = do
     writeIORef transferActiveRef True
 
 -- | Advance the serial clock.
-update :: Int -> State -> IO ()
-update cycles State {..} = do
+update :: State -> Int -> IO ()
+update State {..} cycles = do
   transferActive <- readIORef transferActiveRef
   when transferActive $ do
     reloads <- updateReloadingCounter shiftClock cycles $ readUnboxedRef clockPeriod

core/test/Machine/GBC/CPUSpec.hs

@@ -2,7 +2,10 @@
 {-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
-module Machine.GBC.CPUSpec where
+module Machine.GBC.CPUSpec
+  ( spec
+  )
+where
 
 import           Control.Monad
 import           Control.Monad.IO.Class

core/test/Machine/GBC/DecodeSpec.hs

@@ -4,7 +4,10 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NumericUnderscores #-}
 
-module Machine.GBC.DecodeSpec where
+module Machine.GBC.DecodeSpec
+  ( spec
+  )
+where
 
 import           Control.Monad.Reader
 import           Control.Monad.State

core/test/Machine/GBC/EmulatorSpec.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Machine.GBC.EmulatorSpec where
+module Machine.GBC.EmulatorSpec
+  ( spec
+  )
+where
 
 import           Data.List
 import           Foreign.Ptr

hie.yaml

@@ -6,5 +6,7 @@ cradle:
       component: "hgbc-core:lib"
     - path: "./main/src"
       component: "hgbc-main:lib"
+    - path: "./testing/src"
+      component: "hgbc-testing:test:hgbc-testing"
     - path: "./sdl/src"
       component: "hgbc-sdl:exe:hgbc-sdl"

stack.yaml

@@ -31,6 +31,7 @@ resolver: lts-14.27
 packages:
 - core
 - main
+- testing
 - sdl
 # Dependency packages to be pulled from upstream that are not in the resolver.
 # These entries can reference officially published versions as well as

testing/.gitignore

@@ -0,0 +1 @@
+roms

testing/hgbc-testing.cabal

@@ -0,0 +1,43 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.33.0.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 3162654447ea9adb7faf009f19d31f984aefc9df01d5a54d65de5eb10150579e
+
+name:           hgbc-testing
+version:        0.1.0.0
+description:    Please see the README on GitHub at <https://github.com/CLowcay/hgbc#readme>
+homepage:       https://github.com/CLowcay/hgbc#readme
+bug-reports:    https://github.com/CLowcay/hgbc/issues
+author:         Callum Lowcay
+maintainer:     [email protected]
+copyright:      2019-2020 Callum Lowcay
+license:        BSD3
+build-type:     Simple
+extra-source-files:
+    ../README.md
+
+source-repository head
+  type: git
+  location: https://github.com/CLowcay/hgbc
+
+test-suite hgbc-testing
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  other-modules:
+      Paths_hgbc_testing
+  hs-source-dirs:
+      src
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Wpartial-fields
+  build-depends:
+      base >=4.7 && <5
+    , bytestring
+    , directory
+    , filepath
+    , hgbc-core
+    , hspec
+    , mtl
+    , temporary
+  default-language: Haskell2010

testing/package.yaml

@@ -0,0 +1,44 @@
+name:                hgbc-testing
+version:             0.1.0.0
+github:              "CLowcay/hgbc"
+license:             BSD3
+author:              "Callum Lowcay"
+maintainer:          "[email protected]"
+copyright:           "2019-2020 Callum Lowcay"
+
+extra-source-files:
+- ../README.md
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on GitHub at <https://github.com/CLowcay/hgbc#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+- bytestring
+- directory
+- filepath
+- hgbc-core
+- hspec
+- mtl
+- temporary
+
+tests:
+  hgbc-testing:
+    main:        Main.hs
+    source-dirs: src
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
+      - -Wall
+      - -Wcompat
+      - -Wincomplete-uni-patterns
+      - -Wincomplete-record-updates
+      - -Wredundant-constraints
+      - -Wpartial-fields

testing/src/Main.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main
+  ( main
+  )
+where
+
+import           Control.Concurrent
+import           Control.Exception
+import           Control.Monad.Except
+import           Control.Monad.Reader
+import           Control.Monad.Writer
+import           Data.IORef
+import           Data.Word
+import           Foreign.Marshal.Alloc
+import           Machine.GBC
+import           System.Directory
+import           System.FilePath
+import           System.IO.Temp
+import           Test.Hspec
+import qualified Data.ByteString               as B
+import qualified Data.ByteString.Builder       as BB
+import qualified Data.ByteString.Lazy          as LB
+import qualified Machine.GBC.CPU               as CPU
+import qualified Machine.GBC.Graphics          as Graphics
+import qualified Machine.GBC.Memory            as Memory
+import qualified Machine.GBC.Serial            as Serial
+
+main :: IO ()
+main = hspec $ describe "blargg suite" $ do
+  specify "cpu_instrs" $ do
+    output <- blarggTest "roms/blargg/cpu_instrs.gb" Serial 0x06f1
+    output
+      `shouldBe` "cpu_instrs\n\n01:ok  02:ok  03:ok  04:ok  05:ok  06:ok  07:ok  08:ok  09:ok  10:ok  11:ok  \n\nPassed all tests\n"
+  specify "instr_timing" $ do
+    output <- blarggTest "roms/blargg/instr_timing.gb" Serial 0xC8B0
+    output `shouldBe` "instr_timing\n\n\nPassed\n"
+  specify "mem_timing" $ do
+    output <- blarggTest "roms/blargg/mem_timing.gb" InMemory 0x2BDD
+    output `shouldBe` "mem_timing\n\n01:ok  02:ok  03:ok  \n\nPassed\n"
+  specify "cgb_sound" $ do
+    output <- blarggTest "roms/blargg/cgb_sound.gb" InMemory 0x2BD4
+    output
+      `shouldBe` "cgb_sound\n\n01:ok  02:ok  03:ok  04:ok  05:ok  06:ok  07:ok  08:ok  09:ok  10:ok  11:ok  12:ok  \n\nPassed\n"
+  specify "halt_bug" $ do
+    output <- blarggTest "roms/blargg/halt_bug.gb" InMemory 0xC818
+    output
+      `shouldBe` "halt bug\n\nIE IF IF DE\n01 10 F1 0C04 \n01 00 E1 0C04 \n01 01 E1 0411 \n11 00 E1 0C04 \n11 10 F1 0411 \n11 11 F1 0411 \nE1 00 E1 0C04 \nE1 E0 E1 0C04 \nE1 E1 E1 0411 \n\nPassed\n"
+
+data TestComplete = TestComplete deriving (Eq, Show)
+instance Exception TestComplete
+
+data BlarggOutputStyle = Serial | InMemory deriving (Eq, Show)
+
+blarggTest :: FilePath -> BlarggOutputStyle -> Word16 -> IO B.ByteString
+blarggTest filename outputStyle terminalAddress =
+  withSystemTempDirectory "rom-testing" $ \tempDir -> do
+    let baseName = takeBaseName filename
+    createDirectoryIfMissing True (tempDir </> baseName)
+    let paths = ROMPaths { romFile     = filename
+                         , romSaveFile = tempDir </> baseName </> "battery"
+                         , romRTCFile  = tempDir </> baseName </> "rtc"
+                         }
+
+    romData          <- B.readFile filename
+    (eROM, warnings) <- runWriterT (runExceptT (parseROM paths romData))
+    unless (null warnings) $ fail (show warnings)
+    case eROM of
+      Left  err -> fail (show err)
+      Right rom -> allocaBytes (160 * 144 * 4) $ \frameBuffer -> do
+        serialSync <- Serial.newSync
+        gs         <- newSync
+        buffer     <- newIORef ""
+        bracket (serialHandler serialSync buffer) (`throwTo` TestComplete) $ \_ ->
+          bracket (nullGraphics gs) (`throwTo` TestComplete) $ \_ -> do
+            emulatorState <- initEmulatorState Nothing
+                                               rom
+                                               Nothing
+                                               DefaultColorCorrection
+                                               serialSync
+                                               gs
+                                               frameBuffer
+            runReaderT (reset >> runLoop) emulatorState
+            case outputStyle of
+              InMemory -> flip runReaderT emulatorState $ do
+                Memory.writeByte 0 0x0A
+                liftIO . writeIORef buffer =<< readString 0xA004
+              _ -> pure ()
+        LB.toStrict . BB.toLazyByteString <$> readIORef buffer
+
+ where
+  runLoop = do
+    step
+    pc <- CPU.readPC
+    if pc == terminalAddress then pure () else runLoop
+
+  readString = readString0 ""
+   where
+    readString0 !acc addr = do
+      b <- Memory.readByte addr
+      if b == 0 then pure acc else readString0 (acc <> BB.word8 b) (addr + 1)
+
+  serialHandler sync buffer = case outputStyle of
+    Serial   -> accumulateSerialOutput sync buffer
+    InMemory -> ignoreSerialOutput sync
+
+  ignoreSerialOutput sync = forkIO $ foreverUntil TestComplete $ do
+    void (takeMVar (Serial.out sync))
+    putMVar (Serial.inp sync) 0xFF
+  accumulateSerialOutput sync buffer = forkIO $ foreverUntil TestComplete $ do
+    byte <- takeMVar (Serial.out sync)
+    putMVar (Serial.inp sync) 0xFF
+    modifyIORef' buffer (<> BB.word8 byte)
+  nullGraphics gs = forkIO $ foreverUntil TestComplete $ do
+    takeMVar (Graphics.signalWindow gs)
+    putMVar (Graphics.bufferAvailable gs) ()
+  foreverUntil e action = forever action `catch` (\ex -> if e == ex then pure () else throwIO ex)