Mjau
This commit is contained in:
318
src/GBC/CPU.hs
Normal file
318
src/GBC/CPU.hs
Normal file
@@ -0,0 +1,318 @@
|
||||
{-# LANGUAGE TemplateHaskell
|
||||
, RecordWildCards
|
||||
, DataKinds
|
||||
, FlexibleContexts
|
||||
, GADTs #-}
|
||||
module GBC.CPU where
|
||||
|
||||
import Lens.Micro.Platform
|
||||
import Data.Word
|
||||
import Data.Bits
|
||||
import Data.Int
|
||||
import qualified Data.Vector.Sized as V
|
||||
|
||||
class Convert a b where
|
||||
convert :: a -> b
|
||||
|
||||
data FlagRegister = FlagRegister { _zero :: Bool
|
||||
, _negative :: Bool
|
||||
, _halfCarry :: Bool
|
||||
, _carry :: Bool
|
||||
}
|
||||
deriving Show
|
||||
|
||||
makeLenses ''FlagRegister
|
||||
|
||||
zeroFlagPosition :: Int
|
||||
zeroFlagPosition = 7
|
||||
negativeFlagPosition :: Int
|
||||
negativeFlagPosition = 6
|
||||
halfCarryFlagPosition :: Int
|
||||
halfCarryFlagPosition = 5
|
||||
carryFlagPosition :: Int
|
||||
carryFlagPosition = 4
|
||||
|
||||
instance Convert FlagRegister Word8 where
|
||||
convert r =
|
||||
((.<<. zeroFlagPosition) $ if r ^. zero then 1 else 0) +
|
||||
((.<<. negativeFlagPosition) $ if r ^. negative then 1 else 0) +
|
||||
((.<<. halfCarryFlagPosition) $ if r ^. halfCarry then 1 else 0) +
|
||||
((.<<. carryFlagPosition) $ if r ^. carry then 1 else 0)
|
||||
|
||||
instance Convert Word8 FlagRegister where
|
||||
convert w =
|
||||
let _zero = (w `testBit` zeroFlagPosition)
|
||||
_negative = (w `testBit` negativeFlagPosition)
|
||||
_halfCarry = (w `testBit` halfCarryFlagPosition)
|
||||
_carry = (w `testBit` carryFlagPosition) in
|
||||
FlagRegister {..}
|
||||
|
||||
|
||||
data Registers = Registers { _a :: Word8
|
||||
, _b :: Word8
|
||||
, _c :: Word8
|
||||
, _d :: Word8
|
||||
, _e :: Word8
|
||||
, _f :: Word8
|
||||
, _g :: Word8
|
||||
, _h :: Word8
|
||||
, _l :: Word8
|
||||
, _flags :: FlagRegister
|
||||
}
|
||||
|
||||
makeLenses ''Registers
|
||||
|
||||
bc :: Lens' Registers Word16
|
||||
bc = lens (\r -> (( .<<. 8) . fromIntegral $ r ^. b) + (fromIntegral $ r ^. c))
|
||||
(\r w -> r & b %~ (const $ fromIntegral $ w .>>. 8) & c %~ (const $ fromIntegral $ w .&. 255))
|
||||
|
||||
hl :: Lens' Registers Word16
|
||||
hl = lens (\r -> ((.<<. 8) . fromIntegral $ r ^. h) + (fromIntegral $ r ^. l))
|
||||
(\r w -> r & h %~ (const $ fromIntegral $ w .>>. 8) & l %~ (const $ fromIntegral $ w .&. 255))
|
||||
|
||||
data CPU = CPU { _registers :: Registers
|
||||
, _pc :: Word16
|
||||
, _sp :: Word16
|
||||
, _bus :: (V.Vector 65536 Word8) }
|
||||
makeLenses ''CPU
|
||||
|
||||
type ArithmeticTarget = Lens' Registers Word8
|
||||
|
||||
data Instruction where
|
||||
AddR :: ArithmeticTarget -> Bool -> Instruction
|
||||
AddHL :: Bool -> Instruction
|
||||
AddN :: Word8 -> Bool -> Instruction
|
||||
SubR :: ArithmeticTarget -> Bool -> Instruction
|
||||
SubHL :: Bool -> Instruction
|
||||
SubN :: Word8 -> Bool -> Instruction
|
||||
CpR :: ArithmeticTarget -> Bool -> Instruction
|
||||
CpHL :: Bool -> Instruction
|
||||
CpN :: Word8 -> Bool -> Instruction
|
||||
IncR :: ArithmeticTarget -> Instruction
|
||||
IncHL :: Instruction
|
||||
DecR :: ArithmeticTarget -> Instruction
|
||||
DecHL :: Instruction
|
||||
BOR :: ArithmeticTarget -> (Word8 -> Word8 -> Word8) -> FlagRegister -> Instruction
|
||||
BOHL :: (Word8 -> Word8 -> Word8) -> FlagRegister -> Instruction
|
||||
BON :: Word8 -> (Word8 -> Word8 -> Word8) -> FlagRegister -> Instruction
|
||||
CCF :: Instruction
|
||||
SCF :: Instruction
|
||||
DAA :: Instruction -- TODO: What does this do?
|
||||
CPL :: Instruction
|
||||
|
||||
IncRR :: Instruction
|
||||
DecRR :: Instruction
|
||||
AddHLRR :: Instruction
|
||||
AddSP :: Int8 -> Instruction
|
||||
|
||||
RLCA :: Instruction
|
||||
RRCA :: Instruction
|
||||
RLA :: Instruction
|
||||
RRA :: Instruction
|
||||
RLC :: ArithmeticTarget -> Instruction
|
||||
RLCHL :: Instruction
|
||||
RRC :: ArithmeticTarget -> Instruction
|
||||
RRCHL :: Instruction
|
||||
RL :: ArithmeticTarget -> Instruction
|
||||
RLHL :: Instruction
|
||||
RR :: ArithmeticTarget -> Instruction
|
||||
RRHL :: Instruction
|
||||
|
||||
SLA :: ArithmeticTarget -> Instruction
|
||||
SLAHL :: Instruction
|
||||
SRA :: ArithmeticTarget -> Instruction
|
||||
SRAHL :: Instruction
|
||||
|
||||
execute :: CPU -> Instruction -> CPU
|
||||
execute cpu = \case
|
||||
AddR t _c -> let value = cpu ^. registers . t
|
||||
(newValue, newFlags) = add (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
|
||||
cpu & registers . a .~ newValue
|
||||
& registers . flags .~ newFlags
|
||||
AddHL _c -> let value = fetch cpu $ cpu ^. registers . hl
|
||||
(newValue, newFlags) = add (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
|
||||
cpu & registers . a .~ newValue
|
||||
& registers . flags .~ newFlags
|
||||
AddN value _c -> let (newValue, newFlags) = add (cpu ^. registers . a) value $ _c && cpu ^. registers .flags . carry in
|
||||
cpu & registers . a .~ newValue
|
||||
& registers . flags .~ newFlags
|
||||
SubR t _c -> let value = cpu ^. registers . t
|
||||
(newValue, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
|
||||
cpu & registers . a .~ newValue
|
||||
& registers . flags .~ newFlags
|
||||
SubHL _c -> let value = fetch cpu $ cpu ^. registers . hl
|
||||
(newValue, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
|
||||
cpu & registers . a .~ newValue
|
||||
& registers . flags .~ newFlags
|
||||
SubN value _c -> let (newValue, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers .flags . carry in
|
||||
cpu & registers . a .~ newValue
|
||||
& registers . flags .~ newFlags
|
||||
CpR t _c -> let value = cpu ^. registers . t
|
||||
(_, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
|
||||
cpu & registers . flags .~ newFlags
|
||||
CpHL _c -> let value = fetch cpu $ cpu ^. registers . hl
|
||||
(_, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers . flags . carry in
|
||||
cpu & registers . flags .~ newFlags
|
||||
CpN value _c -> let (_, newFlags) = sub (cpu ^. registers . a) value $ _c && cpu ^. registers .flags . carry in
|
||||
cpu & registers . flags .~ newFlags
|
||||
IncR t -> let (value, newFlags) = add (cpu ^. registers . t) 1 False in
|
||||
cpu & registers . t .~ value
|
||||
& registers . flags .~ newFlags
|
||||
IncHL -> let target = cpu ^. registers . hl
|
||||
value = fetch cpu target
|
||||
(newValue, newFlags) = add value 1 False in
|
||||
write cpu target newValue & registers . flags .~ newFlags
|
||||
DecR t -> let (value, newFlags) = sub (cpu ^. registers . t) 1 False in
|
||||
cpu & registers . t .~ value
|
||||
& registers . flags .~ newFlags
|
||||
DecHL -> let target = cpu ^. registers . hl
|
||||
value = fetch cpu target
|
||||
(newValue, newFlags) = sub value 1 False in
|
||||
write cpu target newValue & registers . flags .~ newFlags
|
||||
BOR t op _f -> let newValue = (cpu ^. registers . a) `op` (cpu ^. registers . t)
|
||||
newFlags = _f {_zero = newValue == 0} in
|
||||
cpu & registers . a .~ newValue
|
||||
& registers . flags .~ newFlags
|
||||
BOHL op _f -> let target = cpu ^. registers . hl
|
||||
value = fetch cpu target
|
||||
newValue = (cpu ^. registers . a) `op` value
|
||||
newFlags = _f {_zero = value == 0} in
|
||||
cpu & registers . a .~ newValue
|
||||
& registers . flags .~ newFlags
|
||||
|
||||
BON value op _f -> let newValue = (cpu ^. registers . a) `op` value
|
||||
newFlags = _f {_zero = newValue == 0} in
|
||||
cpu & registers . a .~ newValue
|
||||
& registers . flags .~ newFlags
|
||||
CCF -> cpu & registers . flags . negative .~ False
|
||||
& registers . flags . halfCarry .~ False
|
||||
& registers . flags . carry %~ not
|
||||
SCF -> cpu & registers . flags . negative .~ False
|
||||
& registers . flags . halfCarry .~ False
|
||||
& registers . flags . carry .~ True
|
||||
DAA -> undefined -- TODO: undefined in manual
|
||||
CPL -> cpu & registers . a %~ complement
|
||||
& registers . flags . negative .~ True
|
||||
& registers . flags . halfCarry .~ True
|
||||
IncRR -> cpu & registers . bc %~ (+1)
|
||||
DecRR -> cpu & registers . bc %~ (+1)
|
||||
AddHLRR -> let _flags = cpu ^. registers . flags
|
||||
_hl = cpu ^. registers . hl
|
||||
_bc = cpu ^. registers . bc
|
||||
(newValue, newFlags) = add16 _hl _bc _flags in
|
||||
cpu & registers . hl .~ newValue
|
||||
& registers . flags .~ newFlags
|
||||
AddSP _e -> let value = cpu ^. sp
|
||||
newValue :: Word16 = fromIntegral (fromIntegral value :: Integer) + (fromIntegral _e) in
|
||||
cpu & sp .~ newValue
|
||||
& registers . flags .~
|
||||
FlagRegister { _zero = False,
|
||||
_negative = False,
|
||||
_halfCarry = value .&. 16 + fromIntegral _e .&. 16 > 16, -- TODO: check if this still works out
|
||||
_carry = value > newValue
|
||||
}
|
||||
RLCA -> let _carry = (cpu ^. registers . a) `testBit` 8 in
|
||||
cpu & registers . a %~ (`rotateL` 1)
|
||||
& registers . flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
|
||||
RRCA -> let _carry = (cpu ^. registers . a) `testBit` 1 in
|
||||
cpu & registers . a %~ (`rotateR` 1)
|
||||
& registers . flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
|
||||
RLA -> let _carry = (cpu ^. registers . a) `testBit` 8
|
||||
_c = cpu ^. registers . flags . carry in
|
||||
cpu & registers . a %~ (if _c then (+1) else id) . (.<<. 1)
|
||||
& registers . flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
|
||||
RRA -> let _carry = (cpu ^. registers . a) `testBit` 1
|
||||
_c = cpu ^. registers . flags . carry in
|
||||
cpu & registers . a %~ (if _c then (+128) else id) . (.>>. 1)
|
||||
& registers . flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
|
||||
RLC t -> let _carry = (cpu ^. registers . t) `testBit` 8
|
||||
newValue = cpu ^. registers . t `rotateL` 1 in
|
||||
cpu & registers . t .~ newValue
|
||||
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
RLCHL -> let target = cpu ^. registers . hl
|
||||
value = fetch cpu target
|
||||
_carry = (value) `testBit` 8
|
||||
newValue = value `rotateL` 1 in
|
||||
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
RRC t -> let _carry = (cpu ^. registers . t) `testBit` 1
|
||||
newValue = cpu ^. registers . t `rotateR` 1 in
|
||||
cpu & registers . t .~ newValue
|
||||
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
RRCHL -> let target = cpu ^. registers . hl
|
||||
value = fetch cpu target
|
||||
_carry = value `testBit` 1
|
||||
newValue = value `rotateR` 1 in
|
||||
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
RL t -> let _carry = (cpu ^. registers . t) `testBit` 8
|
||||
_c = cpu ^. registers . flags . carry
|
||||
newValue = (if _c then (+1) else id) $ cpu ^. registers . t .<<. 1 in
|
||||
cpu & registers . t .~ newValue
|
||||
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
RLHL -> let target = cpu ^. registers . hl
|
||||
value = fetch cpu target
|
||||
_c = cpu ^. registers . flags . carry
|
||||
_carry = value `testBit` 8
|
||||
newValue = (if _c then (+1) else id) $ value .<<. 1 in
|
||||
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
RR t -> let _carry = (cpu ^. registers . t) `testBit` 1
|
||||
_c = cpu ^. registers . flags . carry
|
||||
newValue = (if _c then (+128) else id) $ cpu ^. registers . t .>>. 1 in
|
||||
cpu & registers . t .~ newValue
|
||||
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
RRHL -> let target = cpu ^. registers . hl
|
||||
value = fetch cpu target
|
||||
_c = cpu ^. registers . flags . carry
|
||||
_carry = value `testBit` 1
|
||||
newValue = (if _c then (+128) else id) $ value .>>. 1 in
|
||||
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
SLA t -> let _carry = (cpu ^. registers . t) `testBit` 8
|
||||
newValue = cpu ^. registers . t .<<. 1
|
||||
in
|
||||
cpu & registers . t .~ newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
SLAHL -> let target = cpu ^. registers . hl
|
||||
value = fetch cpu target
|
||||
newValue = value .<<. 1
|
||||
_carry = value `testBit` 8
|
||||
in
|
||||
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
SRA t -> let _carry = (cpu ^. registers . t) `testBit` 1
|
||||
value = cpu ^. registers . t
|
||||
newValue = let temp = value .>>. 1 in if value `testBit` 8 then temp `setBit` 8 else temp
|
||||
in
|
||||
cpu & registers . t .~ newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
SRAHL -> let target = cpu ^. registers . hl
|
||||
value = fetch cpu target
|
||||
newValue = let temp = value .>>. 1 in if value `testBit` 8 then temp `setBit` 8 else temp
|
||||
_carry = value `testBit` 8
|
||||
in
|
||||
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
|
||||
|
||||
where
|
||||
add :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister)
|
||||
add o n _c = let new = o + n + if _c then 1 else 0
|
||||
_zero = new == 0
|
||||
_negative = False
|
||||
_carry = o > new
|
||||
_halfCarry = o .&. 16 + n .&. 16 > 16 in
|
||||
(new, FlagRegister {..})
|
||||
|
||||
add16 :: Word16 -> Word16 -> FlagRegister -> (Word16, FlagRegister)
|
||||
add16 o n _f = let new = o + n
|
||||
_negative = False
|
||||
_carry = o > new
|
||||
_halfCarry = o .&. 16 + n .&. 16 > 16 in
|
||||
(new, _f {_negative, _carry, _halfCarry})
|
||||
|
||||
sub :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister)
|
||||
sub o n _c = let new = o - n - if _c then 1 else 0
|
||||
_zero = new == 0
|
||||
_negative = True
|
||||
_carry = o > new
|
||||
_halfCarry = o .&. 16 + n .&. 16 > 16 in
|
||||
(new, FlagRegister {..})
|
||||
|
||||
fetch :: CPU -> Word16 -> Word8
|
||||
fetch _cpu addr = (`V.index` (fromIntegral addr)) $ _cpu ^. bus
|
||||
|
||||
write :: CPU -> Word16 -> Word8 -> CPU
|
||||
write _cpu target value = _cpu & bus %~ (`V.update` V.singleton (fromIntegral target, value))
|
||||
Reference in New Issue
Block a user