Haskellでゲームボーイエミュレータ

Haskell Advent Calendar 2024 3日目の記事です。

TypescriptやZigでゲームボーイエミュレータを書いたことがあったのでHaskellでも試して見ました。CPUまで書いて力尽きたのでゲームは遊べません。自分でゲームボーイエミュレータ書いてみたいという方はgbdev.ioを見ればだいたいなんとなくおおよそたぶんわかるかと思います。

エミュレータはCPUの命令を実行するたびにレジスタやメモリなどを逐次更新していくことになるのでミュータブルの方が効率が良いと思います。素直にIORefやVector.Mutableなどを使うのがよいと思うわけですが、StateMとLensを使えばミュータブルっぽいインターフェイスですっきり書けそうな気がしました。気がしたんです。

type CPU a = StateT CPUState (StateT MBCState (StateT LoggerState IO)) a

data CPUState = CPUState {
    -- レジスタなど
    _a, __f, ..., :: Word8,
    _pc, _sp, :: Word16,
    ...
    }

makeLenses ''CPU

-- 8ビットレジスタを２つ並べて擬似的に16ビットレジスターとしている
af :: Lens' CPUState Word16
af = lens get set
  where
    get cpu = toWord16 (_a cpu) (__f cpu)
    set cpu ww = cpu { _a = _a', __f = __f'' }
      where
        (_a',__f') = sepWord16 ww
        __f'' = __f' .&. 0b11110000

-- fレジスタの上位4ビットに各種フラグが格納されている
carry :: Lens' CPUState Bool
carry = lens get set
  where
    get cpu = testBit (__f cpu) 4
    set cpu b =
      if b then
        cpu { __f = setBit (__f cpu) 4 }
      else
        cpu { __f = clearBit (__f cpu) 4 }


-- CPUの命令
add :: OP -> CPU ()
add op = do
  a' <- use a -- aレジスタの読み取り
  w <- readOP8 op
  let (a'', c', h') = add8WithCarryHalf a' w
  a .= a'' -- aレジスタの更新

  -- フラグの更新
  zero .= isZero a''
  negative .= False
  half .= h'
  carry .= c'

call :: OP -> CPU ()
call op = do
  ww <- readOP16 WW -- ROM/プログラムから2byte/Word16分の即値を読んでる
  pc' <- use pc
  bool <- cond op -- carryフラグやzeroフラグのオンオフによってジャンプするかしないか
  when bool $ do
    push16 pc'
    pc .= ww

gbe-hs/MonadStackState

ログ用のStateとメモリやROMアクセスを仲介するMBC（メモリバンクコントローラー）用のStateも管理する必要があるためMonadスタックに積み上がってます。主にレコードのフィールドに置いたレジスタの更新にStateMとLensを使っています。

面白い点としては、self的なのがStateMによって隠蔽されてるので明示せずともよい所。各種フラグやレジスタのカスタムアクセサーがlens関数で定義できるのも良い点です。悪い点としては楽したいがためにレジスタの名前をaとかにしてるので一時変数の名前に困り、a'、a''とかになって大変わかりずらい点（自分の名前付けが悪いが書いてるときは楽だった気もする）。

たとえばRustで似たような実装にすればselfの明示が必要になるかと思います。部分的に見ればHaskellのほうがスッキリしているようにも見えます。

fn add(&mut self, op: OP)  {
    let (a, carry, half) = self.a.add_carry_half(self.load8(op));
    self.a = a;
    self.set_carry(carry);
    self.set_half(half);
    self.set_negative(false);
    self.set_zero(self.a == 0);
}

fn call(&mut self, op: OP)  {
    let pc = self.fetch16();
    if self.cond_flag(op) {
        self.push16(self.pc);
        self.pc = pc;
    }
}

さて、上記の実装のような方針で一通り書いて動かしてみたらとても遅い。うちの7950xでもコンパイルに10秒くらいかかるのはいいとしても、実行でエミュレータ開発用のテストROMが落ちるまでに二分ほどかかるのはとてもかなしい（後述の実装では約6秒）。ここまで動くようにするのにStateMとLensと格闘した結果がこれだったのと、昔書いたdeno/typescript版が一秒で起動して約２０秒で実行が終わっていたのもあり、しなしなになり力尽きました。正直テスト通ってないのでどこかでバグり散らかしているせいかもしれませんが。

少しの療養をとったあと、もう少しどうにかならんかと手を入れました。まずモナドスタックが重いのではないかと思いモナドスタックをフラットにしました。

-- 最初の実装
type CPU a = StateT CPUState (StateT MBCState (StateT LoggerState IO)) a

-- メモリアクセスのたびliftが発生する
read :: Address i => i -> CPU Word8
read i = do
  cycle += 1
  lift $ do
    reader' <- use reader
    reader' $ toInt i



-- モナドスタック潰した結果
type GB a = StateT GBState IO a

data GBState = GBState {
  _cpu :: CPUState,
  _mbc :: MBCState,
  _logger :: LoggerState
  }

read :: Address i => i -> GB Word8
read i = do
  cpu.cycleM += 1
  r <- use $ mbc.reader
  r $ toInt i

add :: OP -> GB ()
add op = do
  a' <- use $ cpu.a
  w <- readOP8 op
  let (a'', c', h') = add8CarryHalf a' w

  -- StateMの命令(.=)を複数並べていたのを(%=)一つにまとめている
  cpu %= 
      (a .~ a'')
    . (zero .~ isZero a'')
    . (negative .~ False)
    . (half .~ h')
    . (carry .~ c')

gbe-hs/global-state

モナドスタックを潰した結果として、先ほどのself的なのを書かなくてもいいという利点が消えました。CPUの命令がGB（GameBoy）モナドになっているためです。CPUのためだけの関数なのでスコープを限定したいのですが、実質グローバルステートで各Stateにアクセスできるようにするためこうなってます。(.=)を(%=)にしてStateモナドの命令をまとめているのでコストが下がってる気がしますたぶん。先ほどと同じテストROMを落ちるまで回して2倍くらい早い実行速度になりました。よかったねと言いたい所ですがとてもゲームがプレイアブルな速度にはなってはいなく、やはり悲しみとともに力尽きました。

しばらくの療養を終えたあと、さすがにhaskellがこんなに遅いわけない。ごりごり最適化すればC++並の速度がでるとかでないとかって昔見たような気がするぞわすれたけど。と思い直し、とりあえずすべてのレジスタをVector.Unboxed.Mutableにぶちこめばましになるやろの方針で書き直しました。

import Data.Vector.Unboxed.Mutable qualified as VM

newtype Store a = Store (VM.MVector (VM.PrimState IO) a)

data CPU = CPU { 
  mbc :: MBC,
  cpuLogger :: Logger CPULog,

  regs8 :: Store Word8,
  regs16 :: Store Word16,
  }


data CPUFlags = Carry | Half | Negative | Zero
  deriving (Enum, Show)

data CPURegisters8 = A | F | B | C | D | E | H | L | IME | Halt | Cycle | IsLogging
  deriving (Enum, Show, Eq)

data CPURegisters16 = SP | PC
  deriving (Enum, Show)

readReg8 :: CPU -> CPURegisters8 -> IO Word8
readReg8 (CPU {..}) r = readStore regs8 $ fromEnum r

readReg16 :: CPU -> CPURegisters16 -> IO Word16
readReg16 (CPU {..}) r = readStore regs16 $ fromEnum r

writeReg8 :: CPU -> CPURegisters8 -> Word8 -> IO ()
writeReg8 (CPU {..}) r n = writeStore regs8 (fromEnum r) n

writeReg16 :: CPU -> CPURegisters16 -> Word16 -> IO ()
writeReg16 (CPU {..}) r n = writeStore regs16 (fromEnum r) n

readFlag :: CPU -> CPUFlags -> IO Bool
readFlag cpu flag = do
  f <- readReg8 cpu F
  pure $ testBit f $ 4 + fromEnum flag

writeFlag :: CPU -> CPUFlags -> Bool -> IO ()
writeFlag cpu flag bool = do
  f <- readReg8 cpu F
  let f' = (if bool then setBit else clearBit) f (4 + fromEnum flag)
  writeReg8 cpu F $ f' .&. 0b11110000


add :: CPU -> Op8 -> IO ()
add cpu op = do
  a <- readReg8 cpu A
  n <- readOp8 cpu op
  let (a', carry, half) = addCarryHalf a n
  writeReg8 cpu A a'
  writeFlag cpu Carry carry
  writeFlag cpu Half half
  writeFlag cpu Negative False
  writeFlag cpu Zero $ a' == 0

call :: CPU -> OpCond -> IO ()
call cpu op = do
  nn <- fetch16 cpu

  bool <- condFlag cpu op
  when bool $ do
    pc <- readReg16 cpu PC
    push16 cpu pc
    writeReg16 cpu PC nn

gbe-hs/main

レジスタの値はWord8/16でだいたいいけるのでUnboxedが十分使えました。Stateモナドを撤廃したことでCPUレコードを引数として明示する必要が出てきました。レコードの中身がすべてIOVectorなので状態の引き回しについて考える必要がなかったのが楽でした。レジスターアクセスも直和型として定義したデータ型がそのままderiving(Enum)で配列の添字に使えるのでスッキリしました。

StateM/Lensを使えばスッキリ書けるんじゃないかという目論見は部分的によかったかと思いますが、実用的な速度はでなかったので結局素朴な実装になりました。先程と同じテストROMが約6秒で通るようになり最初の実装から約20倍早くなりゲームプレイもできるレベルであろうと安心して力尽きました。後から書いたRustの実装だと3秒だったので悪くないんじゃないんでしょうかねというかRustもなんか遅い気がしないでもない。

ほどよい歯ごたえだと思うのでみなさんもHaskellでゲームボーイエミュレータ書いてみませんか。λ...