diff options
Diffstat (limited to 'fig-emulator-gb')
| -rw-r--r-- | fig-emulator-gb/fig-emulator-gb.cabal | 59 | ||||
| -rw-r--r-- | fig-emulator-gb/main/Main.hs | 29 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB.hs | 1 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs | 48 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs | 621 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs | 343 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs | 41 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs | 45 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs | 41 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs | 66 |
10 files changed, 1294 insertions, 0 deletions
diff --git a/fig-emulator-gb/fig-emulator-gb.cabal b/fig-emulator-gb/fig-emulator-gb.cabal new file mode 100644 index 0000000..64e6e04 --- /dev/null +++ b/fig-emulator-gb/fig-emulator-gb.cabal @@ -0,0 +1,59 @@ +cabal-version: 3.4 +name: fig-emulator-gb +version: 0.1.0.0 + +common defaults + ghc-options: -Wall + default-language: GHC2021 + default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists RecordWildCards BlockArguments ViewPatterns TypeFamilies DataKinds GADTs + +common deps + build-depends: + base + , aeson + , async + , base64 + , binary + , bytestring + , containers + , data-default-class + , discord-haskell + , directory + , filepath + , lens + , megaparsec + , mtl + , network + , pcre-heavy + , safe-exceptions + , sdl2 + , text + , time + , tomland + , transformers + , unordered-containers + , vector + , fig-utils + , fig-bus + +library + import: defaults + import: deps + hs-source-dirs: src + exposed-modules: + Fig.Emulator.GB + Fig.Emulator.GB.Utils + Fig.Emulator.GB.CPU + Fig.Emulator.GB.CPU.Instruction + Fig.Emulator.GB.Bus + Fig.Emulator.GB.Component.ROM + Fig.Emulator.GB.Component.RAM + Fig.Emulator.GB.Component.Video + +executable fig-emulator-gb + import: defaults + import: deps + build-depends: fig-emulator-gb, optparse-applicative + hs-source-dirs: + main + main-is: Main.hs diff --git a/fig-emulator-gb/main/Main.hs b/fig-emulator-gb/main/Main.hs new file mode 100644 index 0000000..33bf382 --- /dev/null +++ b/fig-emulator-gb/main/Main.hs @@ -0,0 +1,29 @@ +{-# Language ApplicativeDo #-} + +module Main where + +import Fig.Prelude + +import Options.Applicative + +import qualified Data.ByteString as BS + +import Fig.Emulator.GB.CPU + +newtype Options = Options + { romPath :: FilePath + } deriving Show + +parseOptions :: Parser Options +parseOptions = do + romPath <- argument str (metavar "PATH") + pure Options{..} + +main :: IO () +main = do + opts <- execParser $ info (parseOptions <**> helper) + ( fullDesc + <> header "fig-emulator-gb - Game Boy emulator" + ) + rom <- BS.readFile $ romPath opts + testRun rom diff --git a/fig-emulator-gb/src/Fig/Emulator/GB.hs b/fig-emulator-gb/src/Fig/Emulator/GB.hs new file mode 100644 index 0000000..50cb49d --- /dev/null +++ b/fig-emulator-gb/src/Fig/Emulator/GB.hs @@ -0,0 +1 @@ +module Fig.Emulator.GB where diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs new file mode 100644 index 0000000..730378a --- /dev/null +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs @@ -0,0 +1,48 @@ +module Fig.Emulator.GB.Bus + ( Addr(..) + , Component(..) + , Bus(..) + , update + , write + , read + ) where + +import Fig.Prelude + +import Numeric (showHex) + +import qualified Data.List as List +import Data.Word (Word16, Word8) + +newtype Addr = Addr { unAddr :: Word16 } + deriving (Show, Num, Eq, Ord) +instance Pretty Addr where + pretty (Addr w) = "$" <> pack (showHex w "") + +data Component m = forall (s :: Type). Component + { compState :: !s + , compMatches :: !(Addr -> Bool) + , compUpdate :: !(s -> m s) + , compWrite :: !(s -> Addr -> Word8 -> m s) + , compRead :: !(s -> Addr -> m Word8) + } + +newtype Bus m = Bus { busComponents :: [Component m] } + +update :: forall m. MonadIO m => Bus m -> m (Bus m) +update b = Bus <$> forM (busComponents b) \Component{..} -> do + s <- compUpdate compState + pure Component { compState = s, ..} + +write :: forall m. MonadIO m => Bus m -> Addr -> Word8 -> m (Bus m) +write b a v = Bus <$> forM (busComponents b) \c@Component{..} -> + if compMatches a + then do + s <- compWrite compState a v + pure Component { compState = s, ..} + else pure c + +read :: forall m. (MonadIO m, MonadThrow m) => Bus m -> Addr -> m (Maybe Word8) +read b a = case List.find (`compMatches` a) $ busComponents b of + Nothing -> pure Nothing + Just Component{..} -> Just <$> compRead compState a diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs new file mode 100644 index 0000000..33c4ac3 --- /dev/null +++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs @@ -0,0 +1,621 @@ +{-# Language TemplateHaskell, ImplicitParams #-} +module Fig.Emulator.GB.CPU where + +import Control.Lens.TH (makeLenses) + +import Fig.Prelude +import Prelude (fromIntegral) + +import System.IO (withFile, IOMode (WriteMode)) + +import qualified Text.Printf as Pr + +import Control.Lens ((.=), use, (^.)) +import Control.Monad (when, unless) +import Control.Monad.State (StateT(..)) + +import Data.Word (Word8, Word16) +import Data.Bits + +import qualified SDL + +import Fig.Emulator.GB.Utils +import Fig.Emulator.GB.Bus (Bus(..), Addr(..)) +import qualified Fig.Emulator.GB.Bus as Bus +import Fig.Emulator.GB.Component.RAM +import Fig.Emulator.GB.Component.ROM +import Fig.Emulator.GB.Component.Video +import Fig.Emulator.GB.CPU.Instruction + +newtype CPUError = CPUError Text + deriving Show +instance Exception CPUError +instance Pretty CPUError where + pretty (CPUError b) = mconcat + [ "CPU error: " + , b + ] + +data Registers = Registers + { _regA :: !Word8 + , _regB :: !Word8, _regC :: !Word8 + , _regD :: !Word8, _regE :: !Word8 + , _regH :: !Word8, _regL :: !Word8 + , _regSP :: !Word16 + , _regPC :: !Word16 + , _regFlagZ :: !Bool, _regFlagC :: !Bool + , _regFlagN :: !Bool, _regFlagH :: !Bool + , _regFlagIME :: !Bool + } +makeLenses 'Registers + +initialRegs :: Registers +initialRegs = Registers + { _regA = 0x01 + , _regB = 0x00, _regC = 0x13 + , _regD = 0x00, _regE = 0xd8 + , _regH = 0x01, _regL = 0x4d + , _regSP = 0xfffe + , _regPC = 0x0100 + , _regFlagZ = True, _regFlagC = True + , _regFlagN = False, _regFlagH = True + , _regFlagIME = False + } + +data CPU m = CPU + { _lastPC :: !Word16 + , _lastIns :: !Instruction + , _regs :: !Registers + , _bus :: !(Bus m) + } +makeLenses 'CPU + +type EmulatingT f m = (MonadIO m, MonadThrow m, MonadState (CPU f) m, ?log :: Handle) +type Emulating m = EmulatingT IO m + +cpuDMG :: (MonadIO m, MonadThrow m) => ByteString -> CPU m +cpuDMG rom = CPU + { _lastPC = 0x0 + , _lastIns = Nop + , _regs = initialRegs + , _bus = Bus + [ compROM rom + , compWRAM 0x8000 $ 8 * 1024 -- vram placeholder + , compWRAM 0xc000 $ 8 * 1024 + , compLCD + ] + } + +logCPUState :: Emulating m => m () +logCPUState = do + rs <- use regs + let pc = rs ^. regPC + m0 <- read8 $ Addr pc + m1 <- read8 $ Addr pc + 1 + m2 <- read8 $ Addr pc + 2 + m3 <- read8 $ 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" + +decode :: Emulating m => m Instruction +decode = do + b <- use bus + pc <- use $ regs . regPC + lastPC .= pc + (ins, Addr a) <- liftIO $ readInstruction b $ Addr pc + lastIns .= ins + regs . regPC .= a + pure ins + +cond :: Emulating m => Cond -> m Bool +cond CondNz = not <$> use (regs . regFlagZ) +cond CondZ = use (regs . regFlagZ) +cond CondNc = not <$> use (regs . regFlagC) +cond CondC = use (regs . regFlagC) + +read8 :: Emulating m => Addr -> m Word8 +read8 a = do + b <- use bus + pc <- use lastPC + ins <- use lastIns + liftIO (Bus.read b a) >>= \case + Just v -> pure v + Nothing -> throwM . CPUError $ mconcat + [ "read from unmapped address " + , pretty a + , " while executing instruction " + , tshow ins + , " (at " + , pretty $ Addr pc + , ")" + ] + +read16 :: Emulating m => Addr -> m Word16 +read16 a = do + lo <- read8 a + hi <- read8 $ a + 1 + pure $ w8w8 hi lo + +write8 :: Emulating m => Addr -> Word8 -> m () +write8 a v = do + b <- use bus + b' <- liftIO $ Bus.write b a v + bus .= b' + +write16 :: Emulating m => Addr -> Word16 -> m () +write16 a v = do + write8 a $ w16lo v + write8 (a + 1) $ w16hi v + +r8 :: Emulating m => R8 -> m Word8 +r8 R8B = use $ regs . regB +r8 R8C = use $ regs . regC +r8 R8D = use $ regs . regD +r8 R8E = use $ regs . regE +r8 R8H = use $ regs . regH +r8 R8L = use $ regs . regL +r8 R8MemHL = do + hl <- r16 R16HL + read8 $ Addr hl +r8 R8A = use $ regs . regA + +setR8 :: Emulating m => R8 -> Word8 -> m () +setR8 R8B v = regs . regB .= v +setR8 R8C v = regs . regC .= v +setR8 R8D v = regs . regD .= v +setR8 R8E v = regs . regE .= v +setR8 R8H v = regs . regH .= v +setR8 R8L v = regs . regL .= v +setR8 R8MemHL v = do + hl <- r16 R16HL + write8 (Addr hl) v +setR8 R8A v = regs . regA .= v + +r16 :: Emulating m => R16 -> m Word16 +r16 R16BC = w8w8 <$> r8 R8B <*> r8 R8C +r16 R16DE = w8w8 <$> r8 R8D <*> r8 R8E +r16 R16HL = w8w8 <$> r8 R8H <*> r8 R8L +r16 R16SP = use $ regs . regSP + +setR16 :: Emulating m => R16 -> Word16 -> m () +setR16 R16BC v = do + regs . regB .= w16hi v + regs . regC .= w16lo v +setR16 R16DE v = do + regs . regD .= w16hi v + regs . regE .= w16lo v +setR16 R16HL v = do + regs . regH .= w16hi v + regs . regL .= w16lo v +setR16 R16SP v = regs . regSP .= v + +r16Stk :: Emulating m => R16Stk -> m Word16 +r16Stk R16StkBC = r16 R16BC +r16Stk R16StkDE = r16 R16DE +r16Stk R16StkHL = r16 R16HL +r16Stk R16StkAF = do + hi <- r8 R8A + z <- use $ regs . regFlagZ + n <- use $ regs . regFlagN + h <- use $ regs . regFlagH + c <- use $ regs . regFlagC + pure . w8w8 hi $ flagsw8 z n h c + +setR16Stk :: Emulating m => R16Stk -> Word16 -> m () +setR16Stk R16StkBC v = setR16 R16BC v +setR16Stk R16StkDE v = setR16 R16DE v +setR16Stk R16StkHL v = setR16 R16HL v +setR16Stk R16StkAF v = do + setR8 R8A $ w16hi v + let lo = w16lo v + regs . regFlagZ .= w8bit 7 lo + regs . regFlagN .= w8bit 6 lo + regs . regFlagH .= w8bit 5 lo + regs . regFlagC .= w8bit 4 lo + +r16Mem :: Emulating m => R16Mem -> m Word16 +r16Mem R16MemBC = r16 R16BC +r16Mem R16MemDE = r16 R16DE +r16Mem R16MemHLPlus = do + hl <- r16 R16HL + setR16 R16HL $ hl + 1 + pure hl +r16Mem R16MemHLMinus = do + hl <- r16 R16HL + setR16 R16HL $ hl - 1 + pure hl + +renderTile :: Emulating m => SDL.Renderer -> Addr -> Int -> Int -> m () +renderTile renderer a bx by = do + (ps :: [(Int, Int, Word8)]) <- mconcat <$> forM [0..8] \y -> do + mconcat <$> forM [0 .. 1] \x -> do + b <- read8 $ a + Addr (y * 2 + x) + pure + [ (bx + fromIntegral x, by + fromIntegral y, w8bits2 7 b) + , (bx + fromIntegral x, by + fromIntegral y, w8bits2 5 b) + , (bx + fromIntegral x, by + fromIntegral y, w8bits2 3 b) + , (bx + fromIntegral x, by + fromIntegral y, w8bits2 1 b) + ] + SDL.rendererDrawColor renderer SDL.$= SDL.V4 0 0 0 255 + forM_ ps \(x, y, p) -> do + unless (p == 0) do + SDL.drawPoint renderer . SDL.P $ SDL.V2 (fromIntegral x) (fromIntegral y) + +step :: forall m. Emulating m => Instruction -> m () +step ins = do + let + sub8 :: (Word16 -> Word16 -> Word16) -> Word8 -> Word8 -> m Word8 + sub8 op x y = do + let res = op (sext x) (sext y) + regs . regFlagH .= (w8bits4 3 y > w8bits4 3 x) + regs . regFlagC .= (y > x) + regs . regFlagZ .= (res .&. 0xff == 0) + regs . regFlagN .= True + pure $ trunc res + bitwise8 :: (Word8 -> Word8 -> Word8) -> Word8 -> Word8 -> m Word8 + bitwise8 op x y = do + let res = op x y + regs . regFlagH .= False + regs . regFlagC .= False + regs . regFlagZ .= (res .&. 0xff == 0) + regs . regFlagN .= False + pure res + case ins of + Nop -> pure () + LdR16Imm16 r (Imm16 i) -> setR16 r i + LdR16MemA r -> do + addr <- r16Mem r + a <- r8 R8A + write8 (Addr addr) a + LdAR16Mem r -> do + addr <- r16Mem r + v <- read8 $ Addr addr + setR8 R8A v + LdImm16Sp (Imm16 addr) -> do + sp <- r16 R16SP + write8 (Addr addr) $ w16lo sp + write8 (Addr addr + 1) $ w16hi sp + IncR16 r -> do + v <- r16 r + setR16 r $ v + 1 + DecR16 r -> do + v <- r16 r + setR16 r $ v - 1 + AddHlR16 r -> do + x <- r16 R16HL + y <- r16 r + let + res :: Word16 + res = x + y + regs . regFlagH .= (shiftR res 11 .&. 0b1 == 0b1) + regs . regFlagC .= (shiftR res 15 .&. 0b1 == 0b1) + regs . regFlagZ .= (res .&. 0xffff == 0) + regs . regFlagN .= False + setR16 R16HL res + IncR8 r -> do + v <- r8 r + let (res, _) = addC False v 1 + regs . regFlagH .= addH False v 1 + regs . regFlagZ .= (res == 0) + regs . regFlagN .= False + setR8 r res + DecR8 r -> do + v <- r8 r + let + res :: Word8 + res = v - 1 + regs . regFlagH .= subH v 1 + regs . regFlagZ .= (res == 0) + regs . regFlagN .= True + setR8 r res + LdR8Imm8 r (Imm8 i) -> setR8 r i + Rlca -> do + v <- r8 R8A + regs . regFlagH .= False + regs . regFlagZ .= False + regs . regFlagN .= False + regs . regFlagC .= w8bit 7 v + setR8 R8A $ rotateL v 1 + Rrca -> do + v <- r8 R8A + regs . regFlagH .= False + regs . regFlagZ .= False + regs . regFlagN .= False + regs . regFlagC .= w8bit 0 v + setR8 R8A $ rotateR v 1 + Rla -> do + v <- r8 R8A + c <- use $ regs . regFlagC + regs . regFlagH .= False + regs . regFlagZ .= False + regs . regFlagN .= False + regs . regFlagC .= w8bit 7 v + setR8 R8A $ rotateL v 1 .|. if c then 1 else 0 + Rra -> do + v <- r8 R8A + c <- use $ regs . regFlagC + regs . regFlagH .= False + regs . regFlagZ .= False + regs . regFlagN .= False + regs . regFlagC .= w8bit 0 v + setR8 R8A $ rotateR v 1 .|. if c then 0b10000000 else 0 + Daa -> unimplemented + Cpl -> do + v <- r8 R8A + regs . regFlagH .= True + regs . regFlagN .= True + setR8 R8A $ complement v + Scf -> do + regs . regFlagH .= False + regs . regFlagN .= False + regs . regFlagC .= True + Ccf -> do + c <- use $ regs . regFlagC + regs . regFlagH .= False + regs . regFlagN .= False + regs . regFlagC .= not c + JrImm8 (Imm8 i) -> do + pc <- use $ regs . regPC + regs . regPC .= pc + sext i + JrCondImm8 c (Imm8 i) -> do + b <- cond c + when b do + pc <- use $ regs . regPC + regs . regPC .= pc + sext i + Stop -> unimplemented + LdR8R8 dst src -> do + v <- r8 src + setR8 dst v + Halt -> unimplemented + AddAR8 i -> do + x <- r8 R8A + y <- r8 i + let (res, carry) = addC False x y + regs . regFlagH .= addH False x y + regs . regFlagC .= carry + regs . regFlagZ .= (res .&. 0xff == 0) + regs . regFlagN .= False + regs . regA .= res + AdcAR8 i -> do + x <- r8 R8A + y <- r8 i + c <- use $ regs . regFlagC + let (res, carry) = addC c x y + regs . regFlagH .= addH c x y + regs . regFlagC .= carry + regs . regFlagZ .= (res .&. 0xff == 0) + regs . regFlagN .= False + regs . regA .= res + SubAR8 i -> do + x <- r8 R8A + y <- r8 i + res <- sub8 (-) x y + regs . regA .= res + SbcAR8 i -> do + x <- r8 R8A + y <- r8 i + c <- use $ regs . regFlagC + res <- sub8 (\a b -> a - (b + if c then 1 else 0)) x y + regs . regA .= res + AndAR8 i -> do + x <- r8 R8A + y <- r8 i + res <- bitwise8 (.&.) x y + regs . regA .= res + XorAR8 i -> do + x <- r8 R8A + y <- r8 i + res <- bitwise8 xor x y + regs . regA .= res + OrAR8 i -> do + x <- r8 R8A + y <- r8 i + res <- bitwise8 (.|.) x y + regs . regA .= res + CpAR8 i -> do + x <- r8 R8A + y <- r8 i + void $ sub8 (-) x y + AddAImm8 (Imm8 y) -> do + x <- r8 R8A + let (res, carry) = addC False x y + regs . regFlagH .= addH False x y + regs . regFlagC .= carry + regs . regFlagZ .= (res .&. 0xff == 0) + regs . regFlagN .= False + regs . regA .= res + AdcAImm8 (Imm8 y) -> do + x <- r8 R8A + c <- use $ regs . regFlagC + let (res, carry) = addC c x y + regs . regFlagH .= addH c x y + regs . regFlagC .= carry + regs . regFlagZ .= (res .&. 0xff == 0) + regs . regFlagN .= False + regs . regA .= res + SubAImm8 (Imm8 y) -> do + x <- r8 R8A + res <- sub8 (-) x y + regs . regA .= res + SbcAImm8 (Imm8 y) -> do + x <- r8 R8A + c <- use $ regs . regFlagC + res <- sub8 (\a b -> a - (b + if c then 1 else 0)) x y + regs . regA .= res + AndAImm8 (Imm8 y) -> do + x <- r8 R8A + res <- bitwise8 (.&.) x y + regs . regA .= res + XorAImm8 (Imm8 y) -> do + x <- r8 R8A + res <- bitwise8 xor x y + regs . regA .= res + OrAImm8 (Imm8 y) -> do + x <- r8 R8A + res <- bitwise8 (.|.) x y + regs . regA .= res + CpAImm8 (Imm8 y) -> do + x <- r8 R8A + void $ sub8 (-) x y + RetCond c -> do + b <- cond c + when b do + sp <- r16 R16SP + v <- read16 $ Addr sp + setR16 R16SP $ sp + 2 + regs . regPC .= v + Ret -> do + sp <- r16 R16SP + v <- read16 $ Addr sp + setR16 R16SP $ sp + 2 + regs . regPC .= v + Reti -> unimplemented + JpCondImm16 c (Imm16 i) -> do + b <- cond c + when b do + regs . regPC .= i + JpImm16 (Imm16 i) -> do + regs . regPC .= i + JpHl -> do + hl <- r16 R16HL + regs . regPC .= hl + CallCondImm16 c (Imm16 i) -> do + b <- cond c + when b do + next <- use $ regs . regPC + sp <- (\x -> x - 2) <$> r16 R16SP + setR16 R16SP sp + write16 (Addr sp) next + regs . regPC .= i + CallImm16 (Imm16 i) -> do + next <- use $ regs . regPC + sp <- (\x -> x - 2) <$> r16 R16SP + setR16 R16SP sp + write16 (Addr sp) next + regs . regPC .= i + RstTgt3 (Tgt3 v) -> do + next <- use $ regs . regPC + sp <- (\x -> x - 2) <$> r16 R16SP + setR16 R16SP sp + write16 (Addr sp) next + regs . regPC .= shiftL (fromIntegral v) 3 + PopR16Stk r -> do + sp <- r16 R16SP + v <- read16 $ Addr sp + setR16 R16SP $ sp + 2 + setR16Stk r v + PushR16Stk r -> do + sp <- (\x -> x - 2) <$> r16 R16SP + v <- r16Stk r + setR16 R16SP sp + write16 (Addr sp) v + LdhCA -> do + c <- r8 R8C + a <- r8 R8A + write8 (Addr $ 0xff00 + zext c) a + LdhImm8A (Imm8 i) -> do + a <- r8 R8A + write8 (Addr $ 0xff00 + zext i) a + LdImm16A (Imm16 i) -> do + a <- r8 R8A + write8 (Addr i) a + LdhAC -> do + c <- r8 R8C + v <- read8 (Addr $ 0xff00 + zext c) + setR8 R8A v + LdhAImm8 (Imm8 i) -> do + v <- read8 (Addr $ 0xff00 + zext i) + setR8 R8A v + LdAImm16 (Imm16 i) -> do + v <- read8 (Addr i) + setR8 R8A v + AddSpImm8 (Imm8 y) -> do + x <- r16 R16SP + let + res :: Word16 + res = x + sext y + regs . regFlagH .= (shiftR res 3 .&. 0b1 == 0b1) + regs . regFlagC .= (shiftR res 7 .&. 0b1 == 0b1) + regs . regFlagZ .= False + regs . regFlagN .= False + setR16 R16SP res + LdHlSpPlusImm8 (Imm8 y) -> do + x <- r16 R16SP + let + res :: Word16 + res = x + sext y + regs . regFlagH .= (shiftR res 3 .&. 0b1 == 0b1) + regs . regFlagC .= (shiftR res 7 .&. 0b1 == 0b1) + regs . regFlagZ .= False + regs . regFlagN .= False + setR16 R16HL res + LdSpHl -> do + v <- r16 R16HL + setR16 R16SP v + Di -> regs . regFlagIME .= False + Ei -> regs . regFlagIME .= True + CbRlcR8 _ -> unimplemented + CbRrcR8 _ -> unimplemented + CbRlR8 _ -> unimplemented + CbRrR8 _ -> unimplemented + CbSlaR8 _ -> unimplemented + CbSraR8 _ -> unimplemented + CbSwapR8 _ -> unimplemented + CbSrlR8 _ -> unimplemented + CbBitB3R8 _ _ -> unimplemented + CbResB3R8 _ _ -> unimplemented + CbSetB3R8 _ _ -> unimplemented + where + unimplemented :: m () + unimplemented = do + a <- use lastPC + throwM . CPUError $ mconcat + [ "unimplemented instruction (at " + , pretty $ Addr a + , "): " + , tshow ins + ] + +testRun :: forall m. (MonadIO m, MonadThrow m) => ByteString -> m () +testRun rom = do + SDL.initializeAll + window <- SDL.createWindow "taking" SDL.defaultWindow + renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer + let cpu = cpuDMG rom + let + loop :: forall m'. Emulating m' => Int -> m' () + loop cycle = do + -- pc <- use $ regs . regPC + ins <- decode + -- log $ mconcat + -- [ pretty $ Addr pc + -- , ": ", tshow ins + -- ] + step ins + -- logCPUState + when (rem cycle 70224 == 0) do + SDL.rendererDrawColor renderer SDL.$= SDL.V4 255 255 255 255 + SDL.clear renderer + forM_ ([0..255] :: [Int]) \i -> do + renderTile renderer (Addr . fromIntegral $ 0x8000 + i * 16) 0 0 + SDL.present renderer + loop $ cycle + 1 + liftIO $ withFile "log.txt" WriteMode \h -> do + let ?log = h + void $ flip runStateT cpu do + -- logCPUState + loop 0 diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs new file mode 100644 index 0000000..b74a8ee --- /dev/null +++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs @@ -0,0 +1,343 @@ +module Fig.Emulator.GB.CPU.Instruction where + +import Fig.Prelude +import Prelude (Integral, fromIntegral, error) + +import Data.Word (Word8, Word16) + +import Fig.Emulator.GB.Utils +import Fig.Emulator.GB.Bus as Bus + +newtype DecodeError = DecodeError Text + deriving Show +instance Exception DecodeError +instance Pretty DecodeError where + pretty (DecodeError b) = mconcat + [ "instruction decoding error: " + , b + ] + +class ExtractFromOpcode t where + ext :: Integral i => i -> t + +data R8 = R8B | R8C | R8D | R8E | R8H | R8L | R8MemHL | R8A + deriving (Show) +instance ExtractFromOpcode R8 where + ext i = case (fromIntegral i :: Int) of + 0 -> R8B + 1 -> R8C + 2 -> R8D + 3 -> R8E + 4 -> R8H + 5 -> R8L + 6 -> R8MemHL + 7 -> R8A + _ -> error "unreachable" + +data R16 = R16BC | R16DE | R16HL | R16SP + deriving (Show) +instance ExtractFromOpcode R16 where + ext i = case (fromIntegral i :: Int) of + 0 -> R16BC + 1 -> R16DE + 2 -> R16HL + 3 -> R16SP + _ -> error "unreachable" + +data R16Stk = R16StkBC | R16StkDE | R16StkHL | R16StkAF + deriving (Show) +instance ExtractFromOpcode R16Stk where + ext i = case (fromIntegral i :: Int) of + 0 -> R16StkBC + 1 -> R16StkDE + 2 -> R16StkHL + 3 -> R16StkAF + _ -> error "unreachable" + +data R16Mem = R16MemBC | R16MemDE | R16MemHLPlus | R16MemHLMinus + deriving (Show) +instance ExtractFromOpcode R16Mem where + ext i = case (fromIntegral i :: Int) of + 0 -> R16MemBC + 1 -> R16MemDE + 2 -> R16MemHLPlus + 3 -> R16MemHLMinus + _ -> error "unreachable" + +data Cond = CondNz | CondZ | CondNc | CondC + deriving (Show) +instance ExtractFromOpcode Cond where + ext i = case (fromIntegral i :: Int) of + 0 -> CondNz + 1 -> CondZ + 2 -> CondNc + 3 -> CondC + _ -> error "unreachable" + +newtype B3 = B3 Int + deriving (Show) +instance ExtractFromOpcode B3 where + ext i = B3 $ fromIntegral i + +newtype Tgt3 = Tgt3 Int + deriving (Show) +instance ExtractFromOpcode Tgt3 where + ext i = Tgt3 $ fromIntegral i + +newtype Imm8 = Imm8 Word8 + deriving (Show) +readImm8 :: (MonadIO m, MonadThrow m) => Bus.Bus m -> Addr -> m Imm8 +readImm8 b a = Bus.read b a >>= \case + Just i -> pure $ Imm8 i + Nothing -> throwM . DecodeError $ mconcat + [ "failed to read immediate at unmapped address" + , pretty a + ] + +newtype Imm16 = Imm16 Word16 + deriving (Show) +readImm16 :: (MonadIO m, MonadThrow m) => Bus.Bus m -> Addr -> m Imm16 +readImm16 b a = do + mlo <- Bus.read b a + mhi <- Bus.read b $ a + 1 + case (mlo, mhi) of + (Just lo, Just hi) -> pure . Imm16 $ w8w8 hi lo + _otherwise -> throwM . DecodeError $ mconcat + [ "failed to read 16-bit immediate at unmapped address" + , pretty a + ] + +data Instruction + -- Block 0 + = Nop + + | LdR16Imm16 !R16 !Imm16 + | LdR16MemA !R16Mem + | LdAR16Mem !R16Mem + | LdImm16Sp !Imm16 + + | IncR16 !R16 + | DecR16 !R16 + | AddHlR16 !R16 + + | IncR8 !R8 + | DecR8 !R8 + + | LdR8Imm8 !R8 !Imm8 + + | Rlca + | Rrca + | Rla + | Rra + | Daa + | Cpl + | Scf + | Ccf + + | JrImm8 !Imm8 + | JrCondImm8 !Cond !Imm8 + + | Stop + + -- Block 1 + | LdR8R8 !R8 !R8 + + | Halt + + -- Block 2 + | AddAR8 !R8 + | AdcAR8 !R8 + | SubAR8 !R8 + | SbcAR8 !R8 + | AndAR8 !R8 + | XorAR8 !R8 + | OrAR8 !R8 + | CpAR8 !R8 + + -- Block 3 + | AddAImm8 !Imm8 + | AdcAImm8 !Imm8 + | SubAImm8 !Imm8 + | SbcAImm8 !Imm8 + | AndAImm8 !Imm8 + | XorAImm8 !Imm8 + | OrAImm8 !Imm8 + | CpAImm8 !Imm8 + + | RetCond !Cond + | Ret + | Reti + | JpCondImm16 !Cond !Imm16 + | JpImm16 !Imm16 + | JpHl + | CallCondImm16 !Cond !Imm16 + | CallImm16 !Imm16 + | RstTgt3 !Tgt3 + + | PopR16Stk !R16Stk + | PushR16Stk !R16Stk + + | LdhCA + | LdhImm8A !Imm8 + | LdImm16A !Imm16 + | LdhAC + | LdhAImm8 !Imm8 + | LdAImm16 !Imm16 + + | AddSpImm8 !Imm8 + | LdHlSpPlusImm8 !Imm8 + | LdSpHl + + | Di + | Ei + + -- 0xcb prefixed 16-bit instructions + | CbRlcR8 !R8 + | CbRrcR8 !R8 + | CbRlR8 !R8 + | CbRrR8 !R8 + | CbSlaR8 !R8 + | CbSraR8 !R8 + | CbSwapR8 !R8 + | CbSrlR8 !R8 + + | CbBitB3R8 !B3 !R8 + | CbResB3R8 !B3 !R8 + | CbSetB3R8 !B3 !R8 + deriving (Show) + +readInstruction :: + (MonadIO m, MonadThrow m) => + Bus.Bus m -> Addr -> + m (Instruction, Addr) +readInstruction b a = do + op <- Bus.read b a >>= \case + Just o -> pure o + Nothing -> throwM . DecodeError $ mconcat + [ "failed to read opcode at unmapped address " + , pretty a + ] + let blk = w8bits2 7 op + let bot3 = w8bits3 2 op + let bot4 = w8bits4 3 op + let no i = pure (i, a + 1) + let imm8 f = do + x <- readImm8 b $ a + 1 + pure (f x, a + 2) + let imm16 f = do + x <- readImm16 b $ a + 1 + pure (f x, a + 3) + case (op, blk, bot4, bot3) of + -- Block 0 + (0b00000000, _, _, _) -> no Nop + + (_, 0b00, 0b0001, _) -> imm16 $ LdR16Imm16 (ext $ w8bits2 5 op) + (_, 0b00, 0b0010, _) -> no $ LdR16MemA (ext $ w8bits2 5 op) + (_, 0b00, 0b1010, _) -> no $ LdAR16Mem (ext $ w8bits2 5 op) + (0b00001000, _, _, _) -> imm16 LdImm16Sp + + (_, 0b00, 0b0011, _) -> no $ IncR16 (ext $ w8bits2 5 op) + (_, 0b00, 0b1011, _) -> no $ DecR16 (ext $ w8bits2 5 op) + (_, 0b00, 0b1001, _) -> no $ AddHlR16 (ext $ w8bits2 5 op) + + (_, 0b00, _, 0b100) -> no $ IncR8 (ext $ w8bits3 5 op) + (_, 0b00, _, 0b101) -> no $ DecR8 (ext $ w8bits3 5 op) + + (_, 0b00, _, 0b110) -> imm8 $ LdR8Imm8 (ext $ w8bits3 5 op) + + (0b00000111, _, _, _) -> no Rlca + (0b00001111, _, _, _) -> no Rrca + (0b00010111, _, _, _) -> no Rla + (0b00011111, _, _, _) -> no Rra + (0b00100111, _, _, _) -> no Daa + (0b00101111, _, _, _) -> no Cpl + (0b00110111, _, _, _) -> no Scf + (0b00111111, _, _, _) -> no Ccf + + (0b00011000, _, _, _) -> imm8 JrImm8 + (0b00010000, _, _, _) -> no Stop + (_, 0b00, _, 0b000) -> imm8 $ JrCondImm8 (ext $ w8bits2 4 op) + + -- Block 1 + (0b01110110, _, _, _) -> no Halt + (_, 0b01, _, _) -> no $ LdR8R8 (ext $ w8bits3 5 op) (ext $ w8bits3 2 op) + + -- Block 2 + (_, 0b10, _, _) -> do + let ins = case w8bits3 5 op of + 0b000 -> AddAR8 + 0b001 -> AdcAR8 + 0b010 -> SubAR8 + 0b011 -> SbcAR8 + 0b100 -> AndAR8 + 0b101 -> XorAR8 + 0b110 -> OrAR8 + 0b111 -> CpAR8 + _ -> error "unreachable" + no $ ins (ext $ w8bits3 2 op) + + -- Block 3 + (0b11000110, _, _, _) -> imm8 AddAImm8 + (0b11001110, _, _, _) -> imm8 AdcAImm8 + (0b11010110, _, _, _) -> imm8 SubAImm8 + (0b11011110, _, _, _) -> imm8 SbcAImm8 + (0b11100110, _, _, _) -> imm8 AndAImm8 + (0b11101110, _, _, _) -> imm8 XorAImm8 + (0b11110110, _, _, _) -> imm8 OrAImm8 + (0b11111110, _, _, _) -> imm8 CpAImm8 + + (0b11001001, _, _, _) -> no Ret + (0b11011001, _, _, _) -> no Reti + (0b11000011, _, _, _) -> imm16 JpImm16 + (0b11101001, _, _, _) -> no JpHl + (0b11001101, _, _, _) -> imm16 CallImm16 + + (0b11100010, _, _, _) -> no LdhCA + (0b11100000, _, _, _) -> imm8 LdhImm8A + (0b11101010, _, _, _) -> imm16 LdImm16A + (0b11110010, _, _, _) -> no LdhAC + (0b11110000, _, _, _) -> imm8 LdhAImm8 + (0b11111010, _, _, _) -> imm16 LdAImm16 + + (0b11101000, _, _, _) -> imm8 AddSpImm8 + (0b11111000, _, _, _) -> imm8 LdHlSpPlusImm8 + (0b11111001, _, _, _) -> no LdSpHl + + (0b11110011, _, _, _) -> no Di + (0b11111011, _, _, _) -> no Ei + + (0b11001011, _, _, _) -> do + -- 0xcb prefix + op2 <- Bus.read b (a + 1) >>= \case + Just o -> pure o + Nothing -> throwM . DecodeError $ mconcat + [ "failed to read (0xCB-prefixed) opcode at unmapped address " + , pretty $ a + 1 + ] + case w8bits2 7 op2 of + + 0b00 -> case w8bits3 5 op2 of + 0b000 -> pure (CbRlcR8 $ ext $ w8bits3 2 op2, a + 2) + 0b001 -> pure (CbRrcR8 $ ext $ w8bits3 2 op2, a + 2) + 0b010 -> pure (CbRlR8 $ ext $ w8bits3 2 op2, a + 2) + 0b011 -> pure (CbRrR8 $ ext $ w8bits3 2 op2, a + 2) + 0b100 -> pure (CbSlaR8 $ ext $ w8bits3 2 op2, a + 2) + 0b101 -> pure (CbSraR8 $ ext $ w8bits3 2 op2, a + 2) + 0b110 -> pure (CbSwapR8 $ ext $ w8bits3 2 op2, a + 2) + 0b111 -> pure (CbSrlR8 $ ext $ w8bits3 2 op2, a + 2) + _ -> error "unreachable" + 0b01 -> pure (CbBitB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2) + 0b10 -> pure (CbResB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2) + 0b11 -> pure (CbSetB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2) + _ -> error "unreachable" + + (_, 0b11, _, 0b000) -> no $ RetCond (ext $ w8bits2 4 op) + (_, 0b11, _, 0b010) -> imm16 $ JpCondImm16 (ext $ w8bits2 4 op) + (_, 0b11, _, 0b100) -> imm16 $ CallCondImm16 (ext $ w8bits2 4 op) + (_, 0b11, _, 0b111) -> no $ RstTgt3 (ext $ w8bits3 5 op) + (_, 0b11, 0b0001, _) -> no $ PopR16Stk (ext $ w8bits2 5 op) + (_, 0b11, 0b0101, _) -> no $ PushR16Stk (ext $ w8bits2 5 op) + + _unknown -> do + log $ "unknown opcode: " <> tshow op + no Nop diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs new file mode 100644 index 0000000..c88033e --- /dev/null +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs @@ -0,0 +1,41 @@ +module Fig.Emulator.GB.Component.RAM + ( compWRAM + ) where + +import Fig.Prelude +import Prelude (fromIntegral) + +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import Data.Word (Word8) + +import Fig.Emulator.GB.Bus + +newtype RAMError = RAMError Text + deriving Show +instance Exception RAMError +instance Pretty RAMError where + pretty (RAMError b) = mconcat + [ "internal RAM error: " + , b + ] + +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 + , compUpdate = pure + , compWrite = \s ad v -> do + let offset = fromIntegral . unAddr $ ad - start + pure $ V.modify (\ms -> MV.write ms offset v) s + , compRead = \s ad -> do + let offset = fromIntegral . unAddr $ ad - start + case s V.!? offset of + Nothing -> throwM . RAMError $ mconcat + [ "address ", pretty ad, " out of bounds" + ] + Just v -> pure v + } + where + end = start + Addr (fromIntegral size) diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs new file mode 100644 index 0000000..b5ea24f --- /dev/null +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs @@ -0,0 +1,45 @@ +module Fig.Emulator.GB.Component.ROM + ( compROM + ) where + +import Fig.Prelude +import Prelude (fromIntegral) + +import qualified Data.Vector as V +import qualified Data.ByteString as BS + +import Fig.Emulator.GB.Bus + +newtype ROMError = ROMError Text + deriving Show +instance Exception ROMError +instance Pretty ROMError where + pretty (ROMError b) = mconcat + [ "internal ROM error: " + , b + ] + +-- | Initialize base ROM (no mapper) from a ByteString +compROM :: (MonadIO m, MonadThrow m) => ByteString -> Component m +compROM bs = Component + { compState = V.fromList $ BS.unpack bs + , compMatches = \a -> + a >= start && a < end + , compUpdate = pure + , compWrite = \s _ad _v -> + pure s + -- throwM . ROMError $ mconcat + -- [ "tried to write to ROM at ", pretty ad + -- ] + , compRead = \s ad -> do + let offset = fromIntegral . unAddr $ ad - start + case s V.!? offset of + Nothing -> throwM . ROMError $ mconcat + [ "address ", pretty ad, " out of bounds" + ] + Just v -> pure v + } + where + start = 0x0000 + -- end = 0x4000 + end = 0x8000 diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs new file mode 100644 index 0000000..00f0e4d --- /dev/null +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs @@ -0,0 +1,41 @@ +module Fig.Emulator.GB.Component.Video where + +import Fig.Prelude + +import Fig.Emulator.GB.Bus + +newtype VideoError = VideoError Text + deriving Show +instance Exception VideoError +instance Pretty VideoError where + pretty (VideoError b) = mconcat + [ "video error: " + , b + ] + +compLCD :: (MonadIO m, MonadThrow m) => Component m +compLCD = Component + { compState = () + , compMatches = \a -> a >= 0xff40 && a <= 0xff4b + , compUpdate = pure + , compWrite = \s _ _ -> pure s + , compRead = \_ (Addr a) -> do + let off = a - 0xff40 + case off of + 0x0 -> pure 0x00 + 0x1 -> pure 0x00 + 0x2 -> pure 0x00 + 0x3 -> pure 0x00 + 0x4 -> pure 0x00 + 0x5 -> pure 0x00 + 0x6 -> pure 0x00 + 0x7 -> pure 0x00 + 0x8 -> pure 0x00 + 0x9 -> pure 0x00 + 0xa -> pure 0x00 + 0xb -> pure 0x00 + _ -> throwM $ VideoError $ mconcat + [ "address out of bounds for LCD: " + , pretty $ Addr a + ] + } diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs new file mode 100644 index 0000000..694f2ea --- /dev/null +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs @@ -0,0 +1,66 @@ +module Fig.Emulator.GB.Utils where + +import Fig.Prelude + +import Prelude (fromIntegral) + +import Data.Word (Word8, Word16) +import Data.Int (Int8) +import Data.Bits + +w8w8 :: Word8 -> Word8 -> Word16 +w8w8 high low = shiftL (fromIntegral high) 8 .|. fromIntegral low + +w16hi :: Word16 -> Word8 +w16hi v = fromIntegral $ shiftR v 8 + +w16lo :: Word16 -> Word8 +w16lo v = fromIntegral $ v .&. 0xff + +w8bit :: Int -> Word8 -> Bool +w8bit i v = shiftR v i .&. 0b1 == 1 + +w8bits2 :: Int -> Word8 -> Word8 +w8bits2 i v = shiftR v (i - 1) .&. 0b11 + +w8bits3 :: Int -> Word8 -> Word8 +w8bits3 i v = shiftR v (i - 2) .&. 0b111 + +w8bits4 :: Int -> Word8 -> Word8 +w8bits4 i v = shiftR v (i - 3) .&. 0b1111 + +flagsw8 :: Bool -> Bool -> Bool -> Bool -> Word8 +flagsw8 z n h c = + shiftL (if z then 1 else 0) 7 + .|. shiftL (if n then 1 else 0) 6 + .|. shiftL (if h then 1 else 0) 5 + .|. shiftL (if c then 1 else 0) 4 + +zext :: Word8 -> Word16 +zext = fromIntegral + +sext :: Word8 -> Word16 +sext x = fromIntegral y + where + y :: Int8 + y = fromIntegral x + +trunc :: Word16 -> Word8 +trunc = fromIntegral + +addC :: Bool -> Word8 -> Word8 -> (Word8, Bool) +addC c x y = (trunc res, shiftR res 8 .&. 1 == 1) + where + res :: Word16 + res = sext x + sext y + if c then 1 else 0 + +addH :: Bool -> Word8 -> Word8 -> Bool +addH c x y = shiftR res 4 .&. 1 == 1 + where + xlo = x .&. 0xf + ylo = y .&. 0xf + res :: Word8 + res = xlo + ylo + if c then 1 else 0 + +subH :: Word8 -> Word8 -> Bool +subH x y = w8bits4 3 x < w8bits4 3 y |