pingu/Tia
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Remake the lenses

Browse Source
This commit is contained in:
pingu
2026-04-02 11:39:33 +02:00
parent c3985cce7f
commit 5b5b78448d
1 changed files with 104 additions and 91 deletions
Download Patch File Download Diff File Expand all files Collapse all files

195
src/GBC/CPU.hs
View File

@@ -14,10 +14,10 @@ import qualified Data.Vector.Sized as V
class Convert a b where class Convert a b where
convert :: a -> b convert :: a -> b
data FlagRegister = FlagRegister { _zero :: Bool data FlagRegister = FlagRegister { _fZero :: Bool
, _negative :: Bool , _fNegative :: Bool
, _halfCarry :: Bool , _fHalfCarry :: Bool
, _carry :: Bool , _fCarry :: Bool
} }
deriving Show deriving Show
@@ -34,17 +34,17 @@ carryFlagPosition = 4
instance Convert FlagRegister Word8 where instance Convert FlagRegister Word8 where
convert r = convert r =
((.<<. zeroFlagPosition) $ if r ^. zero then 1 else 0) + ((.<<. zeroFlagPosition) $ if r ^. fZero then 1 else 0) +
((.<<. negativeFlagPosition) $ if r ^. negative then 1 else 0) + ((.<<. negativeFlagPosition) $ if r ^. fNegative then 1 else 0) +
((.<<. halfCarryFlagPosition) $ if r ^. halfCarry then 1 else 0) + ((.<<. halfCarryFlagPosition) $ if r ^. fHalfCarry then 1 else 0) +
((.<<. carryFlagPosition) $ if r ^. carry then 1 else 0) ((.<<. carryFlagPosition) $ if r ^. fCarry then 1 else 0)
instance Convert Word8 FlagRegister where instance Convert Word8 FlagRegister where
convert w = convert w =
let _zero = (w `testBit` zeroFlagPosition) let _fZero = (w `testBit` zeroFlagPosition)
_negative = (w `testBit` negativeFlagPosition) _fNegative = (w `testBit` negativeFlagPosition)
_halfCarry = (w `testBit` halfCarryFlagPosition) _fHalfCarry = (w `testBit` halfCarryFlagPosition)
_carry = (w `testBit` carryFlagPosition) in _fCarry = (w `testBit` carryFlagPosition) in
FlagRegister {..} FlagRegister {..}
@@ -99,8 +99,15 @@ bc = lens (^. registers . rbc) (\cpu w -> cpu & registers . rbc .~ w)
de = lens (^. registers . rde) (\cpu w -> cpu & registers . rde .~ w) de = lens (^. registers . rde) (\cpu w -> cpu & registers . rde .~ w)
hl = lens (^. registers . rhl) (\cpu w -> cpu & registers . rhl .~ w) hl = lens (^. registers . rhl) (\cpu w -> cpu & registers . rhl .~ w)
zero, negative, halfCarry, carry :: Lens' CPU Bool
zero = lens (^. flags . fZero) (\cpu _f -> cpu & flags . fZero .~ _f)
negative = lens (^. flags . fNegative) (\cpu _f -> cpu & flags . fNegative .~ _f)
halfCarry = lens (^. flags . fHalfCarry) (\cpu _f -> cpu & flags . fHalfCarry .~ _f)
carry = lens (^. flags . fCarry) (\cpu _f -> cpu & flags . fCarry .~ _f)
type ByteTarget = Lens' CPU Word8 type ByteTarget = Lens' CPU Word8
type WordTarget = Lens' CPU Word16 type WordTarget = Lens' CPU Word16
type FlagTarget = Lens' CPU Bool
data Instruction where data Instruction where
ADDR :: { t :: ByteTarget, withCarry :: Bool } -> Instruction ADDR :: { t :: ByteTarget, withCarry :: Bool } -> Instruction
@@ -177,28 +184,34 @@ data Instruction where
POPRR :: { to' :: WordTarget } -> Instruction POPRR :: { to' :: WordTarget } -> Instruction
LDHLSPE :: { rel :: Int8 } -> Instruction LDHLSPE :: { rel :: Int8 } -> Instruction
JPNN :: { val' :: Word16 } -> Instruction
JPHL :: Instruction
JPCCNN :: { val' :: Word16, flag :: FlagTarget, op'' :: Bool -> Bool } -> Instruction
JRE :: { rel :: Int8 } -> Instruction
JRCCE :: { rel :: Int8, flag :: FlagTarget, op'' :: Bool -> Bool } -> Instruction
execute :: CPU -> Instruction -> CPU execute :: CPU -> Instruction -> CPU
execute cpu = \case execute cpu = \case
ADDR t _c -> let value = cpu ^. t ADDR t _c -> let value = cpu ^. t
(newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. flags . carry in (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
ADDHL _c -> let value = fetch cpu $ cpu ^. hl ADDHL _c -> let value = fetch cpu $ cpu ^. hl
(newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. flags . carry in (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
ADDN value _c -> let (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. flags . carry in ADDN value _c -> let (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
SUBR t _c -> let value = cpu ^. t SUBR t _c -> let value = cpu ^. t
(newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. flags . carry in (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
SUBHL _c -> let value = fetch cpu $ cpu ^. hl SUBHL _c -> let value = fetch cpu $ cpu ^. hl
(newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. flags . carry in (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
SUBN value _c -> let (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. flags . carry in SUBN value _c -> let (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
CPR t -> let value = cpu ^. t CPR t -> let value = cpu ^. t
@@ -224,30 +237,30 @@ execute cpu = \case
(newValue, newFlags) = sub value 1 False in (newValue, newFlags) = sub value 1 False in
write cpu target newValue & flags .~ newFlags write cpu target newValue & flags .~ newFlags
BOR t op _f -> let newValue = (cpu ^. a) `op` (cpu ^. t) BOR t op _f -> let newValue = (cpu ^. a) `op` (cpu ^. t)
newFlags = _f {_zero = newValue == 0} in newFlags = _f {_fZero = newValue == 0} in
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
BOHL op _f -> let target = cpu ^. hl BOHL op _f -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
newValue = (cpu ^. a) `op` value newValue = (cpu ^. a) `op` value
newFlags = _f {_zero = value == 0} in newFlags = _f {_fZero = value == 0} in
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
BON value op _f -> let newValue = (cpu ^. a) `op` value BON value op _f -> let newValue = (cpu ^. a) `op` value
newFlags = _f {_zero = newValue == 0} in newFlags = _f {_fZero = newValue == 0} in
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
CCF -> cpu & flags . negative .~ False CCF -> cpu & negative .~ False
& flags . halfCarry .~ False & halfCarry .~ False
& flags . carry %~ not & carry %~ not
SCF -> cpu & flags . negative .~ False SCF -> cpu & negative .~ False
& flags . halfCarry .~ False & halfCarry .~ False
& flags . carry .~ True & carry .~ True
DAA -> undefined -- TODO: undefined in manual DAA -> undefined -- TODO: undefined in manual
CPL -> cpu & a %~ complement CPL -> cpu & a %~ complement
& flags . negative .~ True & negative .~ True
& flags . halfCarry .~ True & halfCarry .~ True
INCRR -> cpu & bc %~ (+1) INCRR -> cpu & bc %~ (+1)
DECRR -> cpu & bc %~ (+1) DECRR -> cpu & bc %~ (+1)
ADDHLRR t -> let _flags = cpu ^. flags ADDHLRR t -> let _flags = cpu ^. flags
@@ -260,96 +273,96 @@ execute cpu = \case
newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral _e) in newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral _e) in
cpu & sp .~ newValue cpu & sp .~ newValue
& flags .~ & flags .~
FlagRegister { _zero = False, FlagRegister { _fZero = False,
_negative = False, _fNegative = False,
_halfCarry = value .&. 16 + fromIntegral _e .&. 16 > 16, -- TODO: check if this still works out _fHalfCarry = value .&. 16 + fromIntegral _e .&. 16 > 16, -- TODO: check if this still works out
_carry = value > newValue _fCarry = value > newValue
} }
RLCA -> let _carry = (cpu ^. a) `testBit` 8 in RLCA -> let _fCarry = (cpu ^. a) `testBit` 8 in
cpu & a %~ (`rotateL` 1) cpu & a %~ (`rotateL` 1)
& flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..} & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RRCA -> let _carry = (cpu ^. a) `testBit` 1 in RRCA -> let _fCarry = (cpu ^. a) `testBit` 1 in
cpu & a %~ (`rotateR` 1) cpu & a %~ (`rotateR` 1)
& flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..} & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RLA -> let _carry = (cpu ^. a) `testBit` 8 RLA -> let _fCarry = (cpu ^. a) `testBit` 8
_c = cpu ^. flags . carry in _c = cpu ^. carry in
cpu & a %~ (if _c then (+1) else id) . (.<<. 1) cpu & a %~ (if _c then (+1) else id) . (.<<. 1)
& flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..} & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RRA -> let _carry = (cpu ^. a) `testBit` 1 RRA -> let _fCarry = (cpu ^. a) `testBit` 1
_c = cpu ^. flags . carry in _c = cpu ^. carry in
cpu & a %~ (if _c then (+128) else id) . (.>>. 1) cpu & a %~ (if _c then (+128) else id) . (.>>. 1)
& flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..} & flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RLC t -> let _carry = (cpu ^. t) `testBit` 8 RLC t -> let _fCarry = (cpu ^. t) `testBit` 8
newValue = cpu ^. t `rotateL` 1 in newValue = cpu ^. t `rotateL` 1 in
cpu & t .~ newValue cpu & t .~ newValue
& flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RLCHL -> let target = cpu ^. hl RLCHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
_carry = (value) `testBit` 8 _fCarry = (value) `testBit` 8
newValue = value `rotateL` 1 in newValue = value `rotateL` 1 in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RRC t -> let _carry = (cpu ^. t) `testBit` 1 RRC t -> let _fCarry = (cpu ^. t) `testBit` 1
newValue = cpu ^. t `rotateR` 1 in newValue = cpu ^. t `rotateR` 1 in
cpu & t .~ newValue cpu & t .~ newValue
& flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RRCHL -> let target = cpu ^. hl RRCHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
_carry = value `testBit` 1 _fCarry = value `testBit` 1
newValue = value `rotateR` 1 in newValue = value `rotateR` 1 in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RL t -> let _carry = (cpu ^. t) `testBit` 8 RL t -> let _fCarry = (cpu ^. t) `testBit` 8
_c = cpu ^. flags . carry _c = cpu ^. carry
newValue = (if _c then (+1) else id) $ cpu ^. t .<<. 1 in newValue = (if _c then (+1) else id) $ cpu ^. t .<<. 1 in
cpu & t .~ newValue cpu & t .~ newValue
& flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RLHL -> let target = cpu ^. hl RLHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
_c = cpu ^. flags . carry _c = cpu ^. carry
_carry = value `testBit` 8 _fCarry = value `testBit` 8
newValue = (if _c then (+1) else id) $ value .<<. 1 in newValue = (if _c then (+1) else id) $ value .<<. 1 in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RR t -> let _carry = (cpu ^. t) `testBit` 1 RR t -> let _fCarry = (cpu ^. t) `testBit` 1
_c = cpu ^. flags . carry _c = cpu ^. carry
newValue = (if _c then (+128) else id) $ cpu ^. t .>>. 1 in newValue = (if _c then (+128) else id) $ cpu ^. t .>>. 1 in
cpu & t .~ newValue cpu & t .~ newValue
& flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RRHL -> let target = cpu ^. hl RRHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
_c = cpu ^. flags . carry _c = cpu ^. carry
_carry = value `testBit` 1 _fCarry = value `testBit` 1
newValue = (if _c then (+128) else id) $ value .>>. 1 in newValue = (if _c then (+128) else id) $ value .>>. 1 in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SLA t -> let _carry = (cpu ^. t) `testBit` 8 SLA t -> let _fCarry = (cpu ^. t) `testBit` 8
newValue = cpu ^. t .<<. 1 newValue = cpu ^. t .<<. 1
in in
cpu & t .~ newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SLAHL -> let target = cpu ^. hl SLAHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
newValue = value .<<. 1 newValue = value .<<. 1
_carry = value `testBit` 8 _fCarry = value `testBit` 8
in in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SR t arith -> let _carry = (cpu ^. t) `testBit` 1 SR t arith -> let _fCarry = (cpu ^. t) `testBit` 1
value = cpu ^. t value = cpu ^. t
newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp
in in
cpu & t .~ newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SRHL arith -> let target = cpu ^. hl SRHL arith -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp
_carry = value `testBit` 1 in _fCarry = value `testBit` 1 in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SWAP t -> let newValue = cpu ^. t `rotateR` 4 in SWAP t -> let newValue = cpu ^. t `rotateR` 4 in
cpu & t .~ newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, _carry = False} cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, _fCarry = False}
SWAPHL -> let target = cpu ^. hl SWAPHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
newValue = value `rotateR` 4 in newValue = value `rotateR` 4 in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, _carry = False} write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, _fCarry = False}
BIT t i -> let value = cpu ^. t in BIT t i -> let value = cpu ^. t in
cpu & flags %~ (\_f -> _f { _zero = not $ value `testBit` i, _negative = False, _halfCarry = True }) cpu & flags %~ (\_f -> _f { _fZero = not $ value `testBit` i, _fNegative = False, _fHalfCarry = True })
BITHL i -> let target = cpu ^. hl BITHL i -> let target = cpu ^. hl
value = fetch cpu target in value = fetch cpu target in
cpu & flags %~ (\_f -> _f { _zero = not $ value `testBit` i, _negative = False, _halfCarry = True }) cpu & flags %~ (\_f -> _f { _fZero = not $ value `testBit` i, _fNegative = False, _fHalfCarry = True })
RES t i -> cpu & t %~ (`clearBit` i) RES t i -> cpu & t %~ (`clearBit` i)
RESHL i -> let target = cpu ^. hl RESHL i -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
@@ -407,34 +420,34 @@ execute cpu = \case
newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral v) in newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral v) in
cpu & hl .~ value cpu & hl .~ value
& flags .~ & flags .~
FlagRegister { _zero = False, FlagRegister { _fZero = False,
_negative = False, _fNegative = False,
_halfCarry = value .&. 16 + fromIntegral v .&. 16 > 16, -- TODO: check if this still works out _fHalfCarry = value .&. 16 + fromIntegral v .&. 16 > 16, -- TODO: check if this still works out
_carry = value > newValue _fCarry = value > newValue
} }
where where
add :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister) add :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister)
add o n _c = let new = o + n + if _c then 1 else 0 add o n _c = let new = o + n + if _c then 1 else 0
_zero = new == 0 _fZero = new == 0
_negative = False _fNegative = False
_carry = o > new _fCarry = o > new
_halfCarry = o .&. 16 + n .&. 16 > 16 in _fHalfCarry = o .&. 16 + n .&. 16 > 16 in
(new, FlagRegister {..}) (new, FlagRegister {..})
add16 :: Word16 -> Word16 -> FlagRegister -> (Word16, FlagRegister) add16 :: Word16 -> Word16 -> FlagRegister -> (Word16, FlagRegister)
add16 o n _f = let new = o + n add16 o n _f = let new = o + n
_negative = False _fNegative = False
_carry = o > new _fCarry = o > new
_halfCarry = o .&. 16 + n .&. 16 > 16 in _fHalfCarry = o .&. 16 + n .&. 16 > 16 in
(new, _f {_negative, _carry, _halfCarry}) (new, _f {_fNegative, _fCarry, _fHalfCarry})
sub :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister) sub :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister)
sub o n _c = let new = o - n - if _c then 1 else 0 sub o n _c = let new = o - n - if _c then 1 else 0
_zero = new == 0 _fZero = new == 0
_negative = True _fNegative = True
_carry = o > new _fCarry = o > new
_halfCarry = o .&. 16 + n .&. 16 > 16 in _fHalfCarry = o .&. 16 + n .&. 16 > 16 in
(new, FlagRegister {..}) (new, FlagRegister {..})
fetch :: CPU -> Word16 -> Word8 fetch :: CPU -> Word16 -> Word8