diff options
Diffstat (limited to 'fig-emulator-gb/src/Fig/Emulator')
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB.hs | 91 | ||||
| -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 | 692 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs | 342 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs | 33 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs | 23 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs | 24 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs | 40 | ||||
| -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/Serial.hs | 35 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs | 279 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs | 176 | ||||
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs | 90 |
13 files changed, 0 insertions, 1918 deletions
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB.hs b/fig-emulator-gb/src/Fig/Emulator/GB.hs deleted file mode 100644 index a2cfa1d..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB.hs +++ /dev/null @@ -1,91 +0,0 @@ -module Fig.Emulator.GB where - -import Prelude (error) -import Fig.Prelude - -import System.IO (withFile, IOMode (WriteMode)) - -import Control.Lens ((.=), use) -import Control.Monad (when) -import Control.Monad.State.Strict (StateT(..)) - -import qualified Data.Vector as V -import qualified Data.ByteString as BS - -import qualified SDL - -import Fig.Emulator.GB.CPU -import Fig.Emulator.GB.CPU.Instruction -import Fig.Emulator.GB.Bus (Bus(..), Addr(..)) -import Fig.Emulator.GB.Component.RAM -import Fig.Emulator.GB.Component.ROM -import Fig.Emulator.GB.Component.Video -import Fig.Emulator.GB.Component.Joystick -import Fig.Emulator.GB.Component.Serial -import Fig.Emulator.GB.Component.Misc -import Fig.Emulator.GB.Component.Interrupt - -cpuDMG :: Maybe Handle -> ByteString -> Framebuffer -> CPU -cpuDMG serial rom fb = CPU - { _lastPC = 0x0 - , _lastIns = Nop - , _running = True - , _regs = initialRegs - , _bus = Bus - [ compROM rom - , compWRAM 0xc000 $ 8 * 1024 - , compVideo fb - , compJoystick - , compSerial serial - , compInterrupt - , compMisc - , compWRAM 0xff80 0x7e -- HRAM - ] - } - -testRun :: Maybe FilePath -> ByteString -> IO () -testRun serialOut rom = do - SDL.initializeAll - window <- SDL.createWindow "taking" SDL.defaultWindow - fb <- initializeFramebuffer - let withSerial f = case serialOut of - Nothing -> f Nothing - Just p -> withFile p WriteMode $ f . Just - liftIO $ withSerial \hserial -> do - let cpu = cpuDMG hserial rom fb - let - loop :: Int -> Emulating () - 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 1000000 == 0) do - log "1 million" - when (rem cycle 300000 == 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 * 4) - (fromIntegral screenHeight * 4))) - SDL.updateWindowSurface window - r <- use running - when r . loop $ cycle + 1 - void $ flip (runStateT . runEmulating) cpu do - loop 0 diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs deleted file mode 100644 index 2b71f2f..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs +++ /dev/null @@ -1,48 +0,0 @@ -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 = forall (s :: Type). Component - { compState :: !s - , compMatches :: !(Addr -> Bool) - , compUpdate :: !(s -> Word16 -> IO s) - , compWrite :: !(s -> Addr -> Word8 -> IO s) - , compRead :: !(s -> Addr -> IO Word8) - } - -newtype Bus = Bus { busComponents :: [Component] } - -update :: Word16 -> Bus -> IO Bus -update t b = Bus <$> forM (busComponents b) \Component{..} -> do - s <- compUpdate compState t - pure Component { compState = s, ..} - -write :: Bus -> Addr -> Word8 -> IO Bus -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 :: Bus -> Addr -> IO (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 deleted file mode 100644 index 26a00de..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs +++ /dev/null @@ -1,692 +0,0 @@ -{-# Language TemplateHaskell #-} -module Fig.Emulator.GB.CPU - ( CPU(..) - , Registers(..), initialRegs - , Emulating, runEmulating - , running, regs, bus, regPC, regSP - , regA, regB, regC, regD, regE, regH, regL - , regFlagZ, regFlagN, regFlagH, regFlagC - , updateComps - , decode - , step - ) where - -import Control.Lens.TH (makeLenses) - -import Fig.Prelude - -import Control.Lens ((.=), use, (^.)) -import Control.Monad (when) -import Control.Monad.State.Strict (StateT(..)) - -import Data.Word (Word8, Word16, Word32) -import Data.Int (Int8) -import Data.Bits - -import Fig.Emulator.GB.Utils -import Fig.Emulator.GB.Bus (Bus(..), Addr(..)) -import qualified Fig.Emulator.GB.Bus as Bus -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 = CPU - { _lastPC :: Word16 - , _lastIns :: Instruction - , _running :: Bool - , _regs :: Registers - , _bus :: Bus - } -makeLenses 'CPU - -newtype Emulating a = Emulating { runEmulating :: StateT CPU IO a } - deriving (Functor, Applicative, Monad, MonadIO, MonadState CPU, MonadThrow) - --- 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" - --- | Inform all components that the given number of t-cycles have passed -updateComps :: Word16 -> Emulating () -updateComps t = do - b <- use bus - b' <- liftIO $ Bus.update t b - bus .= b' - -decode :: Emulating Instruction -decode = do - updateComps 4 - 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 :: Cond -> Emulating Bool -cond CondNz = not <$> use (regs . regFlagZ) -cond CondZ = use (regs . regFlagZ) -cond CondNc = not <$> use (regs . regFlagC) -cond CondC = use (regs . regFlagC) - -read8 :: Addr -> Emulating Word8 -read8 a = do - updateComps 4 - 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 :: Addr -> Emulating Word16 -read16 a = do - lo <- read8 a - hi <- read8 $ a + 1 - pure $ w8w8 hi lo - -write8 :: Addr -> Word8 -> Emulating () -write8 a v = do - updateComps 4 - b <- use bus - b' <- liftIO $ Bus.write b a v - bus .= b' - -write16 :: Addr -> Word16 -> Emulating () -write16 a v = do - write8 a $ w16lo v - write8 (a + 1) $ w16hi v - -r8 :: R8 -> Emulating 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 :: R8 -> Word8 -> Emulating () -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 :: R16 -> Emulating 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 :: R16 -> Word16 -> Emulating () -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 :: R16Stk -> Emulating 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 :: R16Stk -> Word16 -> Emulating () -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 :: R16Mem -> Emulating 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 - -step :: Instruction -> Emulating () -step ins = do - let - sub8 :: (Word16 -> Word16 -> Word16) -> Word8 -> Word8 -> Emulating 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 -> Emulating 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 -> {-# SCC "Nop" #-} pure () - LdR16Imm16 r (Imm16 i) -> {-# SCC "LdR16Imm16" #-} setR16 r i - LdR16MemA r -> {-# SCC "LdR16MemA" #-} do - addr <- r16Mem r - a <- r8 R8A - write8 (Addr addr) a - LdAR16Mem r -> {-# SCC "LdAR16Mem" #-} do - addr <- r16Mem r - v <- read8 $ Addr addr - setR8 R8A v - LdImm16Sp (Imm16 addr) -> {-# SCC "LdImm16Sp" #-} do - sp <- r16 R16SP - write8 (Addr addr) $ w16lo sp - write8 (Addr addr + 1) $ w16hi sp - IncR16 r -> {-# SCC "IncR16" #-} do - v <- r16 r - setR16 r $ v + 1 - DecR16 r -> {-# SCC "DecR16" #-} do - v <- r16 r - setR16 r $ v - 1 - AddHlR16 r -> {-# SCC "AddHlR16" #-} do - x <- r16 R16HL - y <- r16 r - let - resl :: Word32 - resl = fromIntegral x + fromIntegral y - res :: Word16 - res = fromIntegral resl - regs . regFlagH .= (shiftR ((x .&. 0xfff) + (y .&. 0xfff)) 12 .&. 0b1 == 0b1) - regs . regFlagC .= (shiftR resl 16 .&. 0b1 == 0b1) - regs . regFlagN .= False - setR16 R16HL res - IncR8 r -> {-# SCC "IncR8" #-} 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 -> {-# SCC "DecR8" #-} do - v <- r8 r - let - res :: Word8 - res = v - 1 - regs . regFlagH .= subH False v 1 - regs . regFlagZ .= (res == 0) - regs . regFlagN .= True - setR8 r res - LdR8Imm8 r (Imm8 i) -> {-# SCC "LdR8Imm8" #-} setR8 r i - Rlca -> {-# SCC "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 -> {-# SCC "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 -> {-# SCC "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 $ shiftL v 1 .|. if c then 1 else 0 - Rra -> {-# SCC "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 $ shiftR v 1 .|. if c then 0b10000000 else 0 - Daa -> {-# SCC "Daa" #-} do - v <- r8 R8A - halfcarry <- use $ regs . regFlagH - carry <- use $ regs . regFlagC - subtract <- use $ regs . regFlagN - let - o0 :: Word8 - o0 = if (not subtract && v .&. 0xf > 0x09) || halfcarry then 0x06 else 0x00 - c = (not subtract && v > 0x99) || carry - o1 :: Word8 - o1 = if c then o0 .|. 0x60 else o0 - res = if subtract then v - o1 else v + o1 - regs . regA .= res - regs . regFlagH .= False - regs . regFlagZ .= (res == 0) - regs . regFlagC .= c - pure () - Cpl -> {-# SCC "Cpl" #-} do - v <- r8 R8A - regs . regFlagH .= True - regs . regFlagN .= True - setR8 R8A $ complement v - Scf -> {-# SCC "Scf" #-} do - regs . regFlagH .= False - regs . regFlagN .= False - regs . regFlagC .= True - Ccf -> {-# SCC "Ccf" #-} do - c <- use $ regs . regFlagC - regs . regFlagH .= False - regs . regFlagN .= False - regs . regFlagC .= not c - JrImm8 (Imm8 i) -> {-# SCC "JrImm8" #-} do - pc <- use $ regs . regPC - regs . regPC .= pc + sext i - JrCondImm8 c (Imm8 i) -> {-# SCC "JrCondImm8" #-} do - b <- cond c - when b do - pc <- use $ regs . regPC - regs . regPC .= pc + sext i - Stop -> {-# SCC "Stop" #-} unimplemented - LdR8R8 dst src -> {-# SCC "LdR8R8" #-} do - v <- r8 src - setR8 dst v - Halt -> {-# SCC "Halt" #-} unimplemented - AddAR8 i -> {-# SCC "AddAR8" #-} 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 -> {-# SCC "AdcAR8" #-} 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 -> {-# SCC "SubAR8" #-} do - x <- r8 R8A - y <- r8 i - let (res, carry) = subC False x y - regs . regFlagH .= subH False x y - regs . regFlagC .= carry - regs . regFlagZ .= (res .&. 0xff == 0) - regs . regFlagN .= True - regs . regA .= res - SbcAR8 i -> {-# SCC "SbcAR8" #-} do - x <- r8 R8A - y <- r8 i - c <- use $ regs . regFlagC - let (res, carry) = subC c x y - regs . regFlagH .= subH c x y - regs . regFlagC .= carry - regs . regFlagZ .= (res .&. 0xff == 0) - regs . regFlagN .= True - regs . regA .= res - AndAR8 i -> {-# SCC "AndAR8" #-} do - x <- r8 R8A - y <- r8 i - res <- bitwise8 (.&.) x y - regs . regFlagH .= True - regs . regA .= res - XorAR8 i -> {-# SCC "XorAR8" #-} do - x <- r8 R8A - y <- r8 i - res <- bitwise8 xor x y - regs . regA .= res - OrAR8 i -> {-# SCC "OrAR8" #-} do - x <- r8 R8A - y <- r8 i - res <- bitwise8 (.|.) x y - regs . regA .= res - CpAR8 i -> {-# SCC "CpAR8" #-} do - x <- r8 R8A - y <- r8 i - let (res, carry) = subC False x y - regs . regFlagH .= subH False x y - regs . regFlagC .= carry - regs . regFlagZ .= (res .&. 0xff == 0) - regs . regFlagN .= True - AddAImm8 (Imm8 y) -> {-# SCC "AddAImm8" #-} 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) -> {-# SCC "AdcAImm8" #-} 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) -> {-# SCC "SubAImm8" #-} do - x <- r8 R8A - let (res, carry) = subC False x y - regs . regFlagH .= subH False x y - regs . regFlagC .= carry - regs . regFlagZ .= (res .&. 0xff == 0) - regs . regFlagN .= True - regs . regA .= res - SbcAImm8 (Imm8 y) -> {-# SCC "SbcAImm8" #-} do - x <- r8 R8A - c <- use $ regs . regFlagC - let (res, carry) = subC c x y - regs . regFlagH .= subH c x y - regs . regFlagC .= carry - regs . regFlagZ .= (res .&. 0xff == 0) - regs . regFlagN .= True - regs . regA .= res - AndAImm8 (Imm8 y) -> {-# SCC "AndAImm8" #-} do - x <- r8 R8A - res <- bitwise8 (.&.) x y - regs . regFlagH .= True - regs . regA .= res - XorAImm8 (Imm8 y) -> {-# SCC "XorAImm8" #-} do - x <- r8 R8A - res <- bitwise8 xor x y - regs . regA .= res - OrAImm8 (Imm8 y) -> {-# SCC "OrAImm8" #-} do - x <- r8 R8A - res <- bitwise8 (.|.) x y - regs . regA .= res - CpAImm8 (Imm8 y) -> {-# SCC "CpAImm8" #-} do - x <- r8 R8A - void $ sub8 (-) x y - RetCond c -> {-# SCC "RetCond" #-} do - b <- cond c - when b do - sp <- r16 R16SP - v <- read16 $ Addr sp - setR16 R16SP $ sp + 2 - regs . regPC .= v - Ret -> {-# SCC "Ret" #-} do - sp <- r16 R16SP - v <- read16 $ Addr sp - setR16 R16SP $ sp + 2 - regs . regPC .= v - Reti -> {-# SCC "Reti" #-} do - regs . regFlagIME .= True - sp <- r16 R16SP - v <- read16 $ Addr sp - setR16 R16SP $ sp + 2 - regs . regPC .= v - JpCondImm16 c (Imm16 i) -> {-# SCC "JpCondImm16" #-} do - b <- cond c - when b do - regs . regPC .= i - JpImm16 (Imm16 i) -> {-# SCC "JpImm16" #-} do - regs . regPC .= i - JpHl -> {-# SCC "JpHl" #-} do - hl <- r16 R16HL - regs . regPC .= hl - CallCondImm16 c (Imm16 i) -> {-# SCC "CallCondImm16" #-} 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) -> {-# SCC "CallImm16" #-} do - next <- use $ regs . regPC - sp <- (\x -> x - 2) <$> r16 R16SP - setR16 R16SP sp - write16 (Addr sp) next - regs . regPC .= i - RstTgt3 (Tgt3 v) -> {-# SCC "RstTgt3" #-} 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 -> {-# SCC "PopR16Stk" #-} do - sp <- r16 R16SP - v <- read16 $ Addr sp - setR16 R16SP $ sp + 2 - setR16Stk r v - PushR16Stk r -> {-# SCC "PushR16Stk" #-} do - sp <- (\x -> x - 2) <$> r16 R16SP - v <- r16Stk r - setR16 R16SP sp - write16 (Addr sp) v - LdhCA -> {-# SCC "LdhCA" #-} do - c <- r8 R8C - a <- r8 R8A - write8 (Addr $ 0xff00 + zext c) a - LdhImm8A (Imm8 i) -> {-# SCC "LdhImm8A" #-} do - a <- r8 R8A - write8 (Addr $ 0xff00 + zext i) a - LdImm16A (Imm16 i) -> {-# SCC "LdImm16A" #-} do - a <- r8 R8A - write8 (Addr i) a - LdhAC -> {-# SCC "LdhAC" #-} do - c <- r8 R8C - v <- read8 (Addr $ 0xff00 + zext c) - setR8 R8A v - LdhAImm8 (Imm8 i) -> {-# SCC "LdhAImm8" #-} do - v <- read8 (Addr $ 0xff00 + zext i) - setR8 R8A v - LdAImm16 (Imm16 i) -> {-# SCC "LdAImm16" #-} do - v <- read8 (Addr i) - setR8 R8A v - AddSpImm8 (Imm8 y) -> {-# SCC "AddSpImm8" #-} do - x <- r16 R16SP - let - res :: Word16 - res = x + sext y - (_, carry) = addC False (w16lo x) y - regs . regFlagH .= addH False (w16lo x) y - regs . regFlagC .= carry - regs . regFlagZ .= False - regs . regFlagN .= False - setR16 R16SP res - LdHlSpPlusImm8 (Imm8 y) -> {-# SCC "LdHlSpPlusImm8" #-} do - x <- r16 R16SP - let - res :: Word16 - res = x + sext y - (_, carry) = addC False (w16lo x) y - regs . regFlagH .= addH False (w16lo x) y - regs . regFlagC .= carry - regs . regFlagZ .= False - regs . regFlagN .= False - setR16 R16HL res - LdSpHl -> {-# SCC "LdSpHl" #-} do - v <- r16 R16HL - setR16 R16SP v - Di -> {-# SCC "Di" #-} regs . regFlagIME .= False - Ei -> {-# SCC "Ei" #-} regs . regFlagIME .= True - CbRlcR8 r -> {-# SCC "CbRlcR8" #-} do - v <- r8 r - let res = rotateL v 1 - regs . regFlagH .= False - regs . regFlagZ .= (res == 0) - regs . regFlagN .= False - regs . regFlagC .= w8bit 7 v - setR8 r res - CbRrcR8 r -> {-# SCC "CbRrcR8" #-} do - v <- r8 r - let res = rotateR v 1 - regs . regFlagH .= False - regs . regFlagZ .= (res == 0) - regs . regFlagN .= False - regs . regFlagC .= w8bit 0 v - setR8 r res - CbRlR8 r -> {-# SCC "CbRlR8" #-} do - v <- r8 r - c <- use $ regs . regFlagC - let res = shiftL v 1 .|. if c then 0b1 else 0 - regs . regFlagH .= False - regs . regFlagZ .= (res == 0) - regs . regFlagN .= False - regs . regFlagC .= w8bit 7 v - setR8 r res - CbRrR8 r -> {-# SCC "CbRrR8" #-} do - v <- r8 r - c <- use $ regs . regFlagC - let rizz = shiftR v 1 .|. if c then 0b10000000 else 0 - regs . regFlagH .= False - regs . regFlagZ .= (rizz == 0) - regs . regFlagN .= False - regs . regFlagC .= w8bit 0 v - setR8 r rizz - CbSlaR8 r -> {-# SCC "CbSlaR8" #-} do - v <- r8 r - let res = shiftL v 1 - regs . regFlagZ .= (res == 0) - regs . regFlagH .= False - regs . regFlagN .= False - regs . regFlagC .= w8bit 7 v - setR8 r res - CbSraR8 r -> {-# SCC "CbSraR8" #-} do - v <- r8 r - let - vs :: Int8 - vs = fromIntegral v - ress = shiftR vs 1 - res :: Word8 - res = fromIntegral ress - regs . regFlagZ .= (res == 0) - regs . regFlagH .= False - regs . regFlagN .= False - regs . regFlagC .= w8bit 0 v - setR8 r res - CbSwapR8 r -> {-# SCC "CbSwapR8" #-} do - v <- r8 r - let res = rotate v 4 - regs . regFlagZ .= (res == 0) - regs . regFlagH .= False - regs . regFlagN .= False - regs . regFlagC .= False - setR8 r res - CbSrlR8 r -> {-# SCC "CbSrlR8" #-} do - v <- r8 r - let res = shiftR v 1 - regs . regFlagZ .= (res == 0) - regs . regFlagH .= False - regs . regFlagN .= False - regs . regFlagC .= w8bit 0 v - setR8 r res - CbBitB3R8 (B3 idx) r -> {-# SCC "CbBitB3R8" #-} do - v <- r8 r - regs . regFlagH .= True - regs . regFlagN .= False - regs . regFlagZ .= not (w8bit idx v) - CbResB3R8 (B3 idx) r -> {-# SCC "CbResB3R8" #-} do - v <- r8 r - setR8 r $ v .&. (0xff .^. shiftL 0b1 idx) - CbSetB3R8 (B3 idx) r -> {-# SCC "CbSetB3R8" #-} do - v <- r8 r - setR8 r $ v .|. shiftL 0b1 idx - where - unimplemented :: Emulating () - unimplemented = do - a <- use lastPC - throwM . CPUError $ mconcat - [ "unimplemented instruction (at " - , pretty $ Addr a - , "): " - , tshow ins - ] diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs deleted file mode 100644 index 002d4e0..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs +++ /dev/null @@ -1,342 +0,0 @@ -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 :: Bus.Bus -> Addr -> IO 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 :: Bus.Bus -> Addr -> IO 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 :: - Bus.Bus -> Addr -> - IO (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, _, _, _) -> {-# SCC "DecodeNop" #-} no Nop - - (_, 0b00, 0b0001, _) -> {-# SCC "DecodeLdR16Imm16" #-} imm16 $ LdR16Imm16 (ext $ w8bits2 5 op) - (_, 0b00, 0b0010, _) -> {-# SCC "DecodeLdR16MemA" #-} no $ LdR16MemA (ext $ w8bits2 5 op) - (_, 0b00, 0b1010, _) -> {-# SCC "DecodeLdAR16Mem" #-} no $ LdAR16Mem (ext $ w8bits2 5 op) - (0b00001000, _, _, _) -> {-# SCC "DecodeLdImm16Sp" #-} imm16 LdImm16Sp - - (_, 0b00, 0b0011, _) -> {-# SCC "DecodeIncR16" #-} no $ IncR16 (ext $ w8bits2 5 op) - (_, 0b00, 0b1011, _) -> {-# SCC "DecodeDecR16" #-} no $ DecR16 (ext $ w8bits2 5 op) - (_, 0b00, 0b1001, _) -> {-# SCC "DecodeAddHlR16" #-} no $ AddHlR16 (ext $ w8bits2 5 op) - - (_, 0b00, _, 0b100) -> {-# SCC "DecodeIncR8" #-} no $ IncR8 (ext $ w8bits3 5 op) - (_, 0b00, _, 0b101) -> {-# SCC "DecodeDecR8" #-} no $ DecR8 (ext $ w8bits3 5 op) - - (_, 0b00, _, 0b110) -> {-# SCC "DecodeLdR8Imm8" #-} imm8 $ LdR8Imm8 (ext $ w8bits3 5 op) - - (0b00000111, _, _, _) -> {-# SCC "DecodeRlca" #-} no Rlca - (0b00001111, _, _, _) -> {-# SCC "DecodeRrca" #-} no Rrca - (0b00010111, _, _, _) -> {-# SCC "DecodeRla" #-} no Rla - (0b00011111, _, _, _) -> {-# SCC "DecodeRra" #-} no Rra - (0b00100111, _, _, _) -> {-# SCC "DecodeDaa" #-} no Daa - (0b00101111, _, _, _) -> {-# SCC "DecodeCpl" #-} no Cpl - (0b00110111, _, _, _) -> {-# SCC "DecodeScf" #-} no Scf - (0b00111111, _, _, _) -> {-# SCC "DecodeCcf" #-} no Ccf - - (0b00011000, _, _, _) -> {-# SCC "DecodeJrImm8" #-} imm8 JrImm8 - (0b00010000, _, _, _) -> {-# SCC "DecodeStop" #-} no Stop - (_, 0b00, _, 0b000) -> {-# SCC "DecodeJrCondImm8" #-} imm8 $ JrCondImm8 (ext $ w8bits2 4 op) - - -- Block 1 - (0b01110110, _, _, _) -> {-# SCC "DecodeHalt" #-} no Halt - (_, 0b01, _, _) -> {-# SCC "DecodeLdR8R8" #-} no $ LdR8R8 (ext $ w8bits3 5 op) (ext $ w8bits3 2 op) - - -- Block 2 - (_, 0b10, _, _) -> do - let ins = case w8bits3 5 op of - 0b000 -> {-# SCC "DecodeAddAR8" #-} AddAR8 - 0b001 -> {-# SCC "DecodeAdcAR8" #-} AdcAR8 - 0b010 -> {-# SCC "DecodeSubAR8" #-} SubAR8 - 0b011 -> {-# SCC "DecodeSbcAR8" #-} SbcAR8 - 0b100 -> {-# SCC "DecodeAndAR8" #-} AndAR8 - 0b101 -> {-# SCC "DecodeXorAR8" #-} XorAR8 - 0b110 -> {-# SCC "DecodeOrAR8" #-} OrAR8 - 0b111 -> {-# SCC "DecodeCpAR8" #-} CpAR8 - _ -> error "unreachable" - no $ ins (ext $ w8bits3 2 op) - - -- Block 3 - (0b11000110, _, _, _) -> {-# SCC "DecodeAddAImm8" #-} imm8 AddAImm8 - (0b11001110, _, _, _) -> {-# SCC "DecodeAdcAImm8" #-} imm8 AdcAImm8 - (0b11010110, _, _, _) -> {-# SCC "DecodeSubAImm8" #-} imm8 SubAImm8 - (0b11011110, _, _, _) -> {-# SCC "DecodeSbcAImm8" #-} imm8 SbcAImm8 - (0b11100110, _, _, _) -> {-# SCC "DecodeAndAImm8" #-} imm8 AndAImm8 - (0b11101110, _, _, _) -> {-# SCC "DecodeXorAImm8" #-} imm8 XorAImm8 - (0b11110110, _, _, _) -> {-# SCC "DecodeOrAImm8" #-} imm8 OrAImm8 - (0b11111110, _, _, _) -> {-# SCC "DecodeCpAImm8" #-} imm8 CpAImm8 - - (0b11001001, _, _, _) -> {-# SCC "DecodeRet" #-} no Ret - (0b11011001, _, _, _) -> {-# SCC "DecodeReti" #-} no Reti - (0b11000011, _, _, _) -> {-# SCC "DecodeJpImm16" #-} imm16 JpImm16 - (0b11101001, _, _, _) -> {-# SCC "DecodeJpHl" #-} no JpHl - (0b11001101, _, _, _) -> {-# SCC "DecodeCallImm16" #-} imm16 CallImm16 - - (0b11100010, _, _, _) -> {-# SCC "DecodeLdhCA" #-} no LdhCA - (0b11100000, _, _, _) -> {-# SCC "DecodeLdhImm8A" #-} imm8 LdhImm8A - (0b11101010, _, _, _) -> {-# SCC "DecodeLdImm16A" #-} imm16 LdImm16A - (0b11110010, _, _, _) -> {-# SCC "DecodeLdhAC" #-} no LdhAC - (0b11110000, _, _, _) -> {-# SCC "DecodeLdhAImm8" #-} imm8 LdhAImm8 - (0b11111010, _, _, _) -> {-# SCC "DecodeLdAImm16" #-} imm16 LdAImm16 - - (0b11101000, _, _, _) -> {-# SCC "DecodeAddSpImm8" #-} imm8 AddSpImm8 - (0b11111000, _, _, _) -> {-# SCC "DecodeLdHlSpPlusImm8" #-} imm8 LdHlSpPlusImm8 - (0b11111001, _, _, _) -> {-# SCC "DecodeLdSpHl" #-} no LdSpHl - - (0b11110011, _, _, _) -> {-# SCC "DecodeDi" #-} no Di - (0b11111011, _, _, _) -> {-# SCC "DecodeEi" #-} no Ei - - (0b11001011, _, _, _) -> {-# SCC "DecodeCBPrefix" #-} 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 -> {-# SCC "DecodeCbRlcR8" #-} pure (CbRlcR8 $ ext $ w8bits3 2 op2, a + 2) - 0b001 -> {-# SCC "DecodeCbRrcR8" #-} pure (CbRrcR8 $ ext $ w8bits3 2 op2, a + 2) - 0b010 -> {-# SCC "DecodeCbRlR8" #-} pure (CbRlR8 $ ext $ w8bits3 2 op2, a + 2) - 0b011 -> {-# SCC "DecodeCbRrR8" #-} pure (CbRrR8 $ ext $ w8bits3 2 op2, a + 2) - 0b100 -> {-# SCC "DecodeCbSlaR8" #-} pure (CbSlaR8 $ ext $ w8bits3 2 op2, a + 2) - 0b101 -> {-# SCC "DecodeCbSraR8" #-} pure (CbSraR8 $ ext $ w8bits3 2 op2, a + 2) - 0b110 -> {-# SCC "DecodeCbSwapR8" #-} pure (CbSwapR8 $ ext $ w8bits3 2 op2, a + 2) - 0b111 -> {-# SCC "DecodeCbSrlR8" #-} pure (CbSrlR8 $ ext $ w8bits3 2 op2, a + 2) - _ -> error "unreachable" - 0b01 -> {-# SCC "DecodeCbBitB3R8" #-} pure (CbBitB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2) - 0b10 -> {-# SCC "DecodeCbResB3R8" #-} pure (CbResB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2) - 0b11 -> {-# SCC "DecodeCbSetB3R8" #-} pure (CbSetB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2) - _ -> error "unreachable" - - (_, 0b11, _, 0b000) -> {-# SCC "DecodeRetCond" #-} no $ RetCond (ext $ w8bits2 4 op) - (_, 0b11, _, 0b010) -> {-# SCC "DecodeJpCondImm16" #-} imm16 $ JpCondImm16 (ext $ w8bits2 4 op) - (_, 0b11, _, 0b100) -> {-# SCC "DecodeCallCondImm16" #-} imm16 $ CallCondImm16 (ext $ w8bits2 4 op) - (_, 0b11, _, 0b111) -> {-# SCC "DecodeRstTgt3" #-} no $ RstTgt3 (ext $ w8bits3 5 op) - (_, 0b11, 0b0001, _) -> {-# SCC "DecodePopR16Stk" #-} no $ PopR16Stk (ext $ w8bits2 5 op) - (_, 0b11, 0b0101, _) -> {-# SCC "DecodePushR16Stk" #-} 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/Interrupt.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs deleted file mode 100644 index f6ea420..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Fig.Emulator.GB.Component.Interrupt where - -import Fig.Prelude - -import Fig.Emulator.GB.Utils -import Fig.Emulator.GB.Bus - -newtype InterruptError = InterruptError Text - deriving Show -instance Exception InterruptError -instance Pretty InterruptError where - pretty (InterruptError b) = mconcat - [ "interrupt error: " - , b - ] - -compInterrupt :: Component -compInterrupt = Component - { compState = () - , compMatches = \a -> a == 0xff0f || a == 0xffff - , compUpdate = \s _ -> pure s - , compWrite = \s (Addr a) v -> do - case a of - 0xff0f -> do - -- log $ "set IF:" <> show8 v - pure () - 0xffff -> do - -- log $ "set IE:" <> show8 v - pure () - _ -> throwM . InterruptError $ "write to invalid address: " <> pretty (Addr a) - pure s - , compRead = \_ _ -> pure 0x00 - } diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs deleted file mode 100644 index 7519ea5..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Fig.Emulator.GB.Component.Joystick where - -import Fig.Prelude - -import Fig.Emulator.GB.Bus - -newtype JoystickError = JoystickError Text - deriving Show -instance Exception JoystickError -instance Pretty JoystickError where - pretty (JoystickError b) = mconcat - [ "joystick error: " - , b - ] - -compJoystick :: Component -compJoystick = Component - { compState = () - , compMatches = (== 0xff00) - , compUpdate = \s _ -> pure s - , compWrite = \s _ _ -> pure s - , compRead = \_ _ -> pure 0x00 - } diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs deleted file mode 100644 index be15e56..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Fig.Emulator.GB.Component.Misc where - -import Fig.Prelude - -import Fig.Emulator.GB.Utils -import Fig.Emulator.GB.Bus - -newtype MiscError = MiscError Text - deriving Show -instance Exception MiscError -instance Pretty MiscError where - pretty (MiscError b) = mconcat - [ "misc component error: " - , b - ] - -compMisc :: Component -compMisc = Component - { compState = () - , compMatches = (== 0xff4d) - , compUpdate = \s _ -> pure s - , compWrite = \s _ _ -> pure s - , compRead = \_ _ -> pure 0x00 - } diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs deleted file mode 100644 index 4dc5715..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Fig.Emulator.GB.Component.RAM - ( compWRAM - ) where - -import Fig.Prelude - -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 :: Addr -> Int -> Component -compWRAM start size = Component - { compState = V.replicate size 0 :: V.Vector Word8 - , compMatches = \a -> - a >= start && a <= end - , compUpdate = \s _ -> {-# SCC "ComponentWRAMUpdate" #-} pure s - , compWrite = \s ad v -> {-# SCC "ComponentWRAMWrite" #-} do - let offset = fromIntegral . unAddr $ ad - start - pure $ V.modify (\ms -> MV.write ms offset v) s - , compRead = \s ad -> {-# SCC "ComponentWRAMRead" #-} 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 - 1)) diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs deleted file mode 100644 index 6aafc46..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs +++ /dev/null @@ -1,45 +0,0 @@ -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 :: ByteString -> Component -compROM bs = Component - { compState = V.fromList $ BS.unpack bs - , compMatches = \a -> - a >= start && a < end - , compUpdate = \s _ -> pure s - , 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/Serial.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs deleted file mode 100644 index 3912e5d..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Fig.Emulator.GB.Component.Serial where - -import Fig.Prelude - -import GHC.IO.Handle (hPutChar) - -import Data.Char (chr) - -import Fig.Emulator.GB.Utils -import Fig.Emulator.GB.Bus - -newtype SerialError = SerialError Text - deriving Show -instance Exception SerialError -instance Pretty SerialError where - pretty (SerialError b) = mconcat - [ "serial error: " - , b - ] - -compSerial :: Maybe Handle -> Component -compSerial mh = Component - { compState = () - , compMatches = (== 0xff01) - , compUpdate = \s _ -> pure s - , compWrite = \s _ v -> do - log $ mconcat - [ "wrote serial byte: ", tshow $ chr $ fromIntegral v - ] - case mh of - Nothing -> pure () - Just h -> liftIO . hPutChar h . chr $ fromIntegral v - pure s - , compRead = \_ _ -> pure 0x00 - } diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs deleted file mode 100644 index b1ddadc..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs +++ /dev/null @@ -1,279 +0,0 @@ -module Fig.Emulator.GB.Component.Video where - -import Fig.Prelude -import Prelude (error, ($!)) - -import qualified Foreign.Ptr as Ptr -import qualified Foreign.Storable as St - -import Control.DeepSeq (force) -import Control.Monad (unless) - -import Data.Word (Word8, Word16, Word32) -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as MV - -import qualified SDL - -import Fig.Emulator.GB.Utils -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 - ] - -screenWidth :: Word16 --- screenWidth = 160 -screenWidth = 8 * 32 - -screenHeight :: Word16 --- screenHeight = 144 -screenHeight = 8 * 32 - -newtype Framebuffer = Framebuffer - { fbSurface :: SDL.Surface - } - -initializeFramebuffer :: IO Framebuffer -initializeFramebuffer = do - s <- liftIO $ SDL.createRGBSurface - (SDL.V2 (fromIntegral screenWidth) $ fromIntegral screenHeight) - SDL.RGBA8888 - pure Framebuffer - { fbSurface = s - } - - -logTilemap :: V.Vector Word8 -> IO () -logTilemap v = do - let base = 0x9800 - 0x8000 - bytes <- forM ([0..(32 * 32)] :: [Int]) \i -> do - case v V.!? (base + i) of - Nothing -> error "unreachable" - Just a -> pure a - log $ "tilemap:" <> tshow bytes - -blitPixel :: Word32 -> (Word8, Word8) -> Framebuffer -> IO () -blitPixel c (x, y) fb = do - SDL.lockSurface $ fbSurface fb - (base :: Ptr.Ptr Word32) <- Ptr.castPtr <$> SDL.surfacePixels (fbSurface fb) - let p = Ptr.plusPtr base - $ 4 - * (fromIntegral y * fromIntegral screenWidth + fromIntegral x) - liftIO $ St.poke p c - SDL.unlockSurface $ fbSurface fb - -blitTile :: Int -> V.Vector Word8 -> Int -> (Word8, Word8) -> Framebuffer -> IO () -blitTile base v num (bx, by) fb = do - let a = num * 16 - log "start" - (ps :: [(Word8, Word8, Word8)]) <- mconcat <$> forM [0..7] \y -> do - mconcat <$> forM [0..1] \xb -> do - b <- case v V.!? fromIntegral (base + a + (y * 2 + xb)) of - Just b -> pure b - Nothing -> throwM . VideoError $ mconcat - [ "tile offset ", pretty . Addr $ fromIntegral a - , " out of bounds" - ] - log $ show8 b - pure - [ (bx + fromIntegral xb, by + fromIntegral y, w8bits2 7 b) - , (bx + fromIntegral xb + 1, by + fromIntegral y, w8bits2 5 b) - , (bx + fromIntegral xb + 2, by + fromIntegral y, w8bits2 3 b) - , (bx + fromIntegral xb + 3, by + fromIntegral y, w8bits2 1 b) - ] - forM_ ps \(x, y, p) -> do - unless (p == 0) do - blitPixel - (case p of - 0x01 -> 0xff0000ff - 0x02 -> 0x00ff00ff - 0x03 -> 0x0000ffff - _else -> error "unreachable" - ) - (x, y) fb - -readTileMap :: Int -> V.Vector Word8 -> IO [(Int, Int, Word8)] -readTileMap base vram = do - mconcat <$> forM ([0..32] :: [Int]) \x -> do - forM ([0..32] :: [Int]) \y -> do - case vram V.!? (base + y * 32 + x) of - Nothing -> error "unreachable" - Just a -> pure (x, y, a) - -data VideoAddrRange - = VideoAddrVRAM !Addr - | VideoAddrStatus !Addr - deriving Show - -videoAddrRange :: Addr -> Maybe VideoAddrRange -videoAddrRange a = if - | a >= 0x8000 && a < 0xa000 -> Just . VideoAddrVRAM $ a - 0x8000 - | a >= 0xff40 && a <= 0xff4b -> Just . VideoAddrStatus $ a - 0xff40 - | otherwise -> Nothing - -data RenderState - = RenderOAMSearch - | RenderPixelTransfer - | RenderHBlank - | RenderVBlank - deriving Show - -data VideoState = VideoState - { vstFb :: !Framebuffer - , vstVRAM :: !(V.Vector Word8) - , vstLcdc :: !Word8 - , vstScx :: !Word8 - , vstScy :: !Word8 - , vstLy :: !Word8 - , vstLx :: !Word8 - , vstRenderState :: !RenderState - , vstTick :: !Word16 - } - -compVideo :: Framebuffer -> Component -compVideo framebuffer = Component - { compState = VideoState - { vstFb = framebuffer - , vstVRAM = V.replicate (8 * 1024) 0 - , vstLcdc = 0 - , vstScx = 0 - , vstScy = 0 - , vstLy = 0 - , vstLx = 0 - , vstRenderState = RenderOAMSearch - , vstTick = 0 - } - - , compMatches = isJust . videoAddrRange - - , compUpdate = \s t -> {-# SCC "ComponentVideoUpdate" #-} do - let tick = vstTick s + t - let ly = vstLy s + 1 - case vstRenderState s of - RenderOAMSearch - | tick == 40 -> pure $! s - { vstTick = tick - , vstRenderState = RenderPixelTransfer - } - | otherwise -> pure $! s - { vstTick = tick - } - RenderPixelTransfer - | tick == 200 -> pure $! s - { vstTick = tick - , vstRenderState = RenderHBlank - } - | otherwise -> pure $! s - { vstTick = tick - } - RenderHBlank - | tick == 456 -> do - if ly == 144 - then - pure $! s - { vstTick = 0 - , vstLy = ly - , vstRenderState = RenderVBlank - } - else - pure $! s - { vstTick = 0 - , vstLy = ly - , vstRenderState = RenderOAMSearch - } - | otherwise -> pure $! s - { vstTick = tick - } - RenderVBlank - | tick == 456 -> do - if ly == 153 - then do - -- log "vblank" - -- logTilemap $ vstVRAM s - let bgmapbase = (if w8bit 3 $ vstLcdc s then 0x9c00 else 0x9800) - 0x8000 - let bgbase = (if w8bit 4 $ vstLcdc s then 0x8000 else 0x9000) - 0x8000 - tiles <- readTileMap bgmapbase (vstVRAM s) - blitTile 0 (vstVRAM s) 48 (0, 8) $ vstFb s - -- forM_ tiles \(x, y, tile) -> do - -- blitTile bgbase (vstVRAM s) - -- (fromIntegral $ tile * 16) - -- (fromIntegral x * 8, fromIntegral y * 8) - -- $ vstFb s - -- forM_ (zip [0..] [48,52,45,111,112,32,114,44,105,109,109] :: [(Int, Int)]) \(idx, b) -> do - -- blitTile 0 (vstVRAM s) - -- (fromIntegral b) - -- (fromIntegral $ idx * 8, 0) - -- $ vstFb s - pure $! s - { vstTick = 0 - , vstLy = 0 - , vstRenderState = RenderOAMSearch - } - else - pure $! s - { vstTick = 0 - , vstLy = ly - } - | otherwise -> pure $! s - { vstTick = tick - } - - , compWrite = \s a v -> {-# SCC "ComponentVideoWrite" #-} case videoAddrRange a of - Nothing -> throwM $ VideoError $ mconcat - [ "write address out of bounds for video system: " - , pretty a - ] - Just (VideoAddrVRAM off) -> do - log $ "write to vram: " <> pretty (0x8000 + off) - pure s - { vstVRAM = - V.modify (\ms -> MV.write ms (fromIntegral $ unAddr off) v) $ vstVRAM s - } - Just (VideoAddrStatus off) -> case off of - 0x0 -> do - log $ "write to lcdc: " <> show8 v - pure s { vstLcdc = v } - 0x1 -> pure s - 0x2 -> pure s { vstScx = v } - 0x3 -> pure s { vstScy = v } - 0x4 -> pure s - 0x5 -> pure s - 0x6 -> pure s - 0x7 -> pure s - 0x8 -> pure s - 0x9 -> pure s - 0xa -> pure s - 0xb -> pure s - _ -> pure s - - , compRead = \s a -> {-# SCC "ComponentVideoRead" #-} case videoAddrRange a of - Nothing -> throwM $ VideoError $ mconcat - [ "read address out of bounds for video system: " - , pretty a - ] - Just (VideoAddrStatus off) -> case off of - 0x0 -> pure $ vstLcdc s - 0x1 -> pure 0x00 - 0x2 -> pure $ vstScx s - 0x3 -> pure $ vstScy s - 0x4 -> pure $ vstLy s - -- 0x4 -> pure 0x00 - 0x5 -> pure 0x00 - 0x6 -> pure 0x00 - 0x7 -> pure 0x00 - 0x8 -> pure 0x00 - 0x9 -> pure 0x00 - 0xa -> pure 0x00 - 0xb -> pure 0x00 - _ -> pure 0x00 - Just (VideoAddrVRAM off) -> do - case vstVRAM s V.!? fromIntegral (unAddr off) of - Nothing -> error "unreachable" - Just v -> pure v - } 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 diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs deleted file mode 100644 index 4ad6f24..0000000 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs +++ /dev/null @@ -1,90 +0,0 @@ -module Fig.Emulator.GB.Utils where - -import Fig.Prelude - -import Prelude (fromIntegral) - -import qualified Text.Printf as Pr - -import Data.Word (Word8, Word16) -import Data.Int (Int8) -import Data.Bits - -show8 :: Word8 -> Text -show8 = pack . Pr.printf "%02X" - -show16 :: Word8 -> Text -show16 = pack . Pr.printf "%04X" - -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 - -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 - -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 = zext x + zext 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 - -subC :: Bool -> Word8 -> Word8 -> (Word8, Bool) -subC c x y = (trunc $ xs - ys, yz > xz) - where - xs = sext x - ys = sext y + if c then 1 else 0 - xz = zext x - yz = zext y + if c then 1 else 0 - -subH :: Bool -> Word8 -> Word8 -> Bool -subH c x y = zext (w8bits4 3 x) < (zext (w8bits4 3 y) + if c then 1 else 0) |