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
convert :: a -> b
data FlagRegister = FlagRegister { _zero :: Bool
, _negative :: Bool
, _halfCarry :: Bool
, _carry :: Bool
data FlagRegister = FlagRegister { _fZero :: Bool
, _fNegative :: Bool
, _fHalfCarry :: Bool
, _fCarry :: Bool
}
deriving Show
@@ -34,17 +34,17 @@ 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)
((.<<. zeroFlagPosition) $ if r ^. fZero then 1 else 0) +
((.<<. negativeFlagPosition) $ if r ^. fNegative then 1 else 0) +
((.<<. halfCarryFlagPosition) $ if r ^. fHalfCarry then 1 else 0) +
((.<<. carryFlagPosition) $ if r ^. fCarry 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
let _fZero = (w `testBit` zeroFlagPosition)
_fNegative = (w `testBit` negativeFlagPosition)
_fHalfCarry = (w `testBit` halfCarryFlagPosition)
_fCarry = (w `testBit` carryFlagPosition) in
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)
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 WordTarget = Lens' CPU Word16
type FlagTarget = Lens' CPU Bool
data Instruction where
ADDR :: { t :: ByteTarget, withCarry :: Bool } -> Instruction
@@ -177,28 +184,34 @@ data Instruction where
POPRR :: { to' :: WordTarget } -> 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 = \case
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
& flags .~ newFlags
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
& 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
& flags .~ newFlags
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
& flags .~ newFlags
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
& 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
& flags .~ newFlags
CPR t -> let value = cpu ^. t
@@ -224,30 +237,30 @@ execute cpu = \case
(newValue, newFlags) = sub value 1 False in
write cpu target newValue & flags .~ newFlags
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
& flags .~ newFlags
BOHL op _f -> let target = cpu ^. hl
value = fetch cpu target
newValue = (cpu ^. a) `op` value
newFlags = _f {_zero = value == 0} in
newFlags = _f {_fZero = value == 0} in
cpu & a .~ newValue
& flags .~ newFlags
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
& flags .~ newFlags
CCF -> cpu & flags . negative .~ False
& flags . halfCarry .~ False
& flags . carry %~ not
SCF -> cpu & flags . negative .~ False
& flags . halfCarry .~ False
& flags . carry .~ True
CCF -> cpu & negative .~ False
& halfCarry .~ False
& carry %~ not
SCF -> cpu & negative .~ False
& halfCarry .~ False
& carry .~ True
DAA -> undefined -- TODO: undefined in manual
CPL -> cpu & a %~ complement
& flags . negative .~ True
& flags . halfCarry .~ True
& negative .~ True
& halfCarry .~ True
INCRR -> cpu & bc %~ (+1)
DECRR -> cpu & bc %~ (+1)
ADDHLRR t -> let _flags = cpu ^. flags
@@ -260,96 +273,96 @@ execute cpu = \case
newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral _e) in
cpu & sp .~ newValue
& flags .~
FlagRegister { _zero = False,
_negative = False,
_halfCarry = value .&. 16 + fromIntegral _e .&. 16 > 16, -- TODO: check if this still works out
_carry = value > newValue
FlagRegister { _fZero = False,
_fNegative = False,
_fHalfCarry = value .&. 16 + fromIntegral _e .&. 16 > 16, -- TODO: check if this still works out
_fCarry = value > newValue
}
RLCA -> let _carry = (cpu ^. a) `testBit` 8 in
RLCA -> let _fCarry = (cpu ^. a) `testBit` 8 in
cpu & a %~ (`rotateL` 1)
& flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
RRCA -> let _carry = (cpu ^. a) `testBit` 1 in
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RRCA -> let _fCarry = (cpu ^. a) `testBit` 1 in
cpu & a %~ (`rotateR` 1)
& flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
RLA -> let _carry = (cpu ^. a) `testBit` 8
_c = cpu ^. flags . carry in
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RLA -> let _fCarry = (cpu ^. a) `testBit` 8
_c = cpu ^. carry in
cpu & a %~ (if _c then (+1) else id) . (.<<. 1)
& flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
RRA -> let _carry = (cpu ^. a) `testBit` 1
_c = cpu ^. flags . carry in
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RRA -> let _fCarry = (cpu ^. a) `testBit` 1
_c = cpu ^. carry in
cpu & a %~ (if _c then (+128) else id) . (.>>. 1)
& flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..}
RLC t -> let _carry = (cpu ^. t) `testBit` 8
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RLC t -> let _fCarry = (cpu ^. t) `testBit` 8
newValue = cpu ^. t `rotateL` 1 in
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
value = fetch cpu target
_carry = (value) `testBit` 8
_fCarry = (value) `testBit` 8
newValue = value `rotateL` 1 in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RRC t -> let _carry = (cpu ^. t) `testBit` 1
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RRC t -> let _fCarry = (cpu ^. t) `testBit` 1
newValue = cpu ^. t `rotateR` 1 in
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
value = fetch cpu target
_carry = value `testBit` 1
_fCarry = value `testBit` 1
newValue = value `rotateR` 1 in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RL t -> let _carry = (cpu ^. t) `testBit` 8
_c = cpu ^. flags . carry
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RL t -> let _fCarry = (cpu ^. t) `testBit` 8
_c = cpu ^. carry
newValue = (if _c then (+1) else id) $ cpu ^. t .<<. 1 in
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
value = fetch cpu target
_c = cpu ^. flags . carry
_carry = value `testBit` 8
_c = cpu ^. carry
_fCarry = value `testBit` 8
newValue = (if _c then (+1) else id) $ value .<<. 1 in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RR t -> let _carry = (cpu ^. t) `testBit` 1
_c = cpu ^. flags . carry
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RR t -> let _fCarry = (cpu ^. t) `testBit` 1
_c = cpu ^. carry
newValue = (if _c then (+128) else id) $ cpu ^. t .>>. 1 in
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
value = fetch cpu target
_c = cpu ^. flags . carry
_carry = value `testBit` 1
_c = cpu ^. carry
_fCarry = value `testBit` 1
newValue = (if _c then (+128) else id) $ value .>>. 1 in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
SLA t -> let _carry = (cpu ^. t) `testBit` 8
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SLA t -> let _fCarry = (cpu ^. t) `testBit` 8
newValue = cpu ^. t .<<. 1
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
value = fetch cpu target
newValue = value .<<. 1
_carry = value `testBit` 8
_fCarry = value `testBit` 8
in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
SR t arith -> let _carry = (cpu ^. t) `testBit` 1
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SR t arith -> let _fCarry = (cpu ^. t) `testBit` 1
value = cpu ^. t
newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp
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
value = fetch cpu target
newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp
_carry = value `testBit` 1 in
write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
_fCarry = value `testBit` 1 in
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
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
value = fetch cpu target
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
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
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)
RESHL i -> let target = cpu ^. hl
value = fetch cpu target
@@ -407,34 +420,34 @@ execute cpu = \case
newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral v) in
cpu & hl .~ value
& flags .~
FlagRegister { _zero = False,
_negative = False,
_halfCarry = value .&. 16 + fromIntegral v .&. 16 > 16, -- TODO: check if this still works out
_carry = value > newValue
FlagRegister { _fZero = False,
_fNegative = False,
_fHalfCarry = value .&. 16 + fromIntegral v .&. 16 > 16, -- TODO: check if this still works out
_fCarry = value > newValue
}
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
_fZero = new == 0
_fNegative = False
_fCarry = o > new
_fHalfCarry = 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})
_fNegative = False
_fCarry = o > new
_fHalfCarry = o .&. 16 + n .&. 16 > 16 in
(new, _f {_fNegative, _fCarry, _fHalfCarry})
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
_fZero = new == 0
_fNegative = True
_fCarry = o > new
_fHalfCarry = o .&. 16 + n .&. 16 > 16 in
(new, FlagRegister {..})
fetch :: CPU -> Word16 -> Word8