From c3985cce7f3f65301a49bb8642c8d0264dc19dc2 Mon Sep 17 00:00:00 2001 From: pingu Date: Thu, 2 Apr 2026 11:16:31 +0200 Subject: [PATCH] hehe, new lenses --- src/GBC/CPU.hs | 299 ++++++++++++++++++++++++++----------------------- 1 file changed, 159 insertions(+), 140 deletions(-) diff --git a/src/GBC/CPU.hs b/src/GBC/CPU.hs index f0018b0..e88f0d7 100644 --- a/src/GBC/CPU.hs +++ b/src/GBC/CPU.hs @@ -48,31 +48,31 @@ instance Convert Word8 FlagRegister where FlagRegister {..} -data Registers = Registers { _a :: Word8 - , _b :: Word8 - , _c :: Word8 - , _d :: Word8 - , _e :: Word8 - , _f :: Word8 - , _g :: Word8 - , _h :: Word8 - , _l :: Word8 - , _flags :: FlagRegister +data Registers = Registers { _ra :: Word8 + , _rb :: Word8 + , _rc :: Word8 + , _rd :: Word8 + , _re :: Word8 + , _rf :: Word8 + , _rg :: Word8 + , _rh :: Word8 + , _rl :: Word8 + , _rflags :: 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)) +rbc :: Lens' Registers Word16 +rbc = lens (\r -> (( .<<. 8) . fromIntegral $ r ^. rb) + (fromIntegral $ r ^. rc)) + (\r w -> r & rb %~ (const $ fromIntegral $ w .>>. 8) & rc %~ (const $ fromIntegral $ w .&. 255)) -de :: Lens' Registers Word16 -de = lens (\r -> (( .<<. 8) . fromIntegral $ r ^. d) + (fromIntegral $ r ^. e)) - (\r w -> r & d %~ (const $ fromIntegral $ w .>>. 8) & e %~ (const $ fromIntegral $ w .&. 255)) +rde :: Lens' Registers Word16 +rde = lens (\r -> (( .<<. 8) . fromIntegral $ r ^. rd) + (fromIntegral $ r ^. re)) + (\r w -> r & rd %~ (const $ fromIntegral $ w .>>. 8) & re %~ (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)) +rhl :: Lens' Registers Word16 +rhl = lens (\r -> ((.<<. 8) . fromIntegral $ r ^. rh) + (fromIntegral $ r ^. rl)) + (\r w -> r & rh %~ (const $ fromIntegral $ w .>>. 8) & rl %~ (const $ fromIntegral $ w .&. 255)) data CPU = CPU { _registers :: Registers , _pc :: Word16 @@ -80,6 +80,25 @@ data CPU = CPU { _registers :: Registers , _bus :: (V.Vector 65536 Word8) } makeLenses ''CPU +a, b, c, d, e, f, g, h, l :: Lens' CPU Word8 +a = lens (^. registers . ra) (\cpu w -> cpu & registers . ra .~ w) +b = lens (^. registers . rb) (\cpu w -> cpu & registers . rb .~ w) +c = lens (^. registers . rc) (\cpu w -> cpu & registers . rc .~ w) +d = lens (^. registers . rd) (\cpu w -> cpu & registers . rd .~ w) +e = lens (^. registers . re) (\cpu w -> cpu & registers . re .~ w) +f = lens (^. registers . rf) (\cpu w -> cpu & registers . rf .~ w) +g = lens (^. registers . rg) (\cpu w -> cpu & registers . rg .~ w) +h = lens (^. registers . rh) (\cpu w -> cpu & registers . rh .~ w) +l = lens (^. registers . rl) (\cpu w -> cpu & registers . rl .~ w) + +flags :: Lens' CPU FlagRegister +flags = lens (^. registers . rflags) (\cpu _f -> cpu & registers . rflags .~ _f) + +bc, de, hl :: Lens' CPU Word16 +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) + type ByteTarget = Lens' CPU Word8 type WordTarget = Lens' CPU Word16 @@ -161,217 +180,217 @@ data Instruction where execute :: CPU -> Instruction -> CPU execute cpu = \case ADDR t _c -> let value = cpu ^. 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 + (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. flags . 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 + cpu & a .~ newValue + & flags .~ newFlags + ADDN value _c -> let (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. flags . carry in + cpu & a .~ newValue + & flags .~ newFlags SUBR t _c -> let value = cpu ^. 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 + (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. flags . 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 + cpu & a .~ newValue + & flags .~ newFlags + SUBN value _c -> let (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. flags . carry in + cpu & a .~ newValue + & flags .~ newFlags CPR t -> let value = cpu ^. t - (_, newFlags) = sub (cpu ^. registers . a) value $ False in - cpu & registers . flags .~ newFlags - CPHL -> let value = fetch cpu $ cpu ^. registers . hl - (_, newFlags) = sub (cpu ^. registers . a) value $ False in - cpu & registers . flags .~ newFlags - CPN value -> let (_, newFlags) = sub (cpu ^. registers . a) value $ False in - cpu & registers . flags .~ newFlags + (_, newFlags) = sub (cpu ^. a) value $ False in + cpu & flags .~ newFlags + CPHL -> let value = fetch cpu $ cpu ^. hl + (_, newFlags) = sub (cpu ^. a) value $ False in + cpu & flags .~ newFlags + CPN value -> let (_, newFlags) = sub (cpu ^. a) value $ False in + cpu & flags .~ newFlags INCR t -> let (value, newFlags) = add (cpu ^. t) 1 False in cpu & t .~ value - & registers . flags .~ newFlags - INCHL -> let target = cpu ^. registers . hl + & flags .~ newFlags + INCHL -> let target = cpu ^. hl value = fetch cpu target (newValue, newFlags) = add value 1 False in - write cpu target newValue & registers . flags .~ newFlags + write cpu target newValue & flags .~ newFlags DECR t -> let (value, newFlags) = sub (cpu ^. t) 1 False in cpu & t .~ value - & registers . flags .~ newFlags - DECHL -> let target = cpu ^. registers . hl + & flags .~ newFlags + DECHL -> let target = cpu ^. 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 ^. t) + write cpu target newValue & flags .~ newFlags + BOR t op _f -> let newValue = (cpu ^. a) `op` (cpu ^. t) newFlags = _f {_zero = newValue == 0} in - cpu & registers . a .~ newValue - & registers . flags .~ newFlags - BOHL op _f -> let target = cpu ^. registers . hl + cpu & a .~ newValue + & flags .~ newFlags + BOHL op _f -> let target = cpu ^. hl value = fetch cpu target - newValue = (cpu ^. registers . a) `op` value + newValue = (cpu ^. a) `op` value newFlags = _f {_zero = value == 0} in - cpu & registers . a .~ newValue - & registers . flags .~ newFlags + cpu & a .~ newValue + & flags .~ newFlags - BON value op _f -> let newValue = (cpu ^. registers . a) `op` value + BON value op _f -> let newValue = (cpu ^. 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 + 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 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 t -> let _flags = cpu ^. registers . flags - _hl = cpu ^. registers . hl + CPL -> cpu & a %~ complement + & flags . negative .~ True + & flags . halfCarry .~ True + INCRR -> cpu & bc %~ (+1) + DECRR -> cpu & bc %~ (+1) + ADDHLRR t -> let _flags = cpu ^. flags + _hl = cpu ^. hl val = cpu ^. t (newValue, newFlags) = add16 _hl val _flags in - cpu & registers . hl .~ newValue - & registers . flags .~ newFlags + cpu & hl .~ newValue + & flags .~ newFlags ADDSP _e -> let value = cpu ^. sp newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral _e) in cpu & sp .~ newValue - & registers . flags .~ + & 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, ..} + RLCA -> let _carry = (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 + cpu & a %~ (`rotateR` 1) + & flags .~ FlagRegister {_zero = False, _negative = False, _halfCarry = False, ..} + RLA -> let _carry = (cpu ^. a) `testBit` 8 + _c = cpu ^. flags . 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 + 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 newValue = cpu ^. t `rotateL` 1 in cpu & t .~ newValue - & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} - RLCHL -> let target = cpu ^. registers . hl + & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} + RLCHL -> let target = cpu ^. 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, ..} + write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} RRC t -> let _carry = (cpu ^. t) `testBit` 1 newValue = cpu ^. t `rotateR` 1 in cpu & t .~ newValue - & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} - RRCHL -> let target = cpu ^. registers . hl + & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} + RRCHL -> let target = cpu ^. 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, ..} + write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} RL t -> let _carry = (cpu ^. t) `testBit` 8 - _c = cpu ^. registers . flags . carry + _c = cpu ^. flags . carry newValue = (if _c then (+1) else id) $ cpu ^. t .<<. 1 in cpu & t .~ newValue - & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} - RLHL -> let target = cpu ^. registers . hl + & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} + RLHL -> let target = cpu ^. hl value = fetch cpu target - _c = cpu ^. registers . flags . carry + _c = cpu ^. 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, ..} + write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} RR t -> let _carry = (cpu ^. t) `testBit` 1 - _c = cpu ^. registers . flags . carry + _c = cpu ^. flags . carry newValue = (if _c then (+128) else id) $ cpu ^. t .>>. 1 in cpu & t .~ newValue - & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} - RRHL -> let target = cpu ^. registers . hl + & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} + RRHL -> let target = cpu ^. hl value = fetch cpu target - _c = cpu ^. registers . flags . carry + _c = cpu ^. 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, ..} + write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} SLA t -> let _carry = (cpu ^. t) `testBit` 8 newValue = cpu ^. t .<<. 1 in - cpu & t .~ newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} - SLAHL -> let target = cpu ^. registers . hl + cpu & t .~ newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} + SLAHL -> let target = cpu ^. 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, ..} + write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} SR t arith -> let _carry = (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 & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} - SRHL arith -> let target = cpu ^. registers . hl + cpu & t .~ newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = 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 & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} + write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} SWAP t -> let newValue = cpu ^. t `rotateR` 4 in - cpu & t .~ newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, _carry = False} - SWAPHL -> let target = cpu ^. registers . hl + cpu & t .~ newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, _carry = False} + SWAPHL -> let target = cpu ^. hl value = fetch cpu target newValue = value `rotateR` 4 in - write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, _carry = False} + write cpu target newValue & flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, _carry = False} BIT t i -> let value = cpu ^. t in - cpu & registers . flags %~ (\_f -> _f { _zero = not $ value `testBit` i, _negative = False, _halfCarry = True }) - BITHL i -> let target = cpu ^. registers . hl + cpu & flags %~ (\_f -> _f { _zero = not $ value `testBit` i, _negative = False, _halfCarry = True }) + BITHL i -> let target = cpu ^. hl value = fetch cpu target in - cpu & registers . flags %~ (\_f -> _f { _zero = not $ value `testBit` i, _negative = False, _halfCarry = True }) + cpu & flags %~ (\_f -> _f { _zero = not $ value `testBit` i, _negative = False, _halfCarry = True }) RES t i -> cpu & t %~ (`clearBit` i) - RESHL i -> let target = cpu ^. registers . hl + RESHL i -> let target = cpu ^. hl value = fetch cpu target newValue = value `clearBit` i in write cpu target newValue SET t i -> cpu & t %~ (`setBit` i) - SETHL i -> let target = cpu ^. registers . hl + SETHL i -> let target = cpu ^. hl value = fetch cpu target newValue = value `setBit` i in write cpu target newValue LDRR t _f -> cpu & t .~ cpu ^. _f LDRN t v -> cpu & t .~ v - LDRHL t -> let target = cpu ^. registers . hl + LDRHL t -> let target = cpu ^. hl value = fetch cpu target in cpu & t .~ value LDXR t _f -> let target = cpu ^. t in write cpu target $ cpu ^. _f LDXN t v -> let target = cpu ^. t in write cpu target v - LDANN _f -> cpu & registers . a .~ fetch cpu _f - LDNNA _t -> write cpu _t $ cpu ^. registers . a - LDHAC -> let target = 65280 + (fromIntegral $ cpu ^. registers . c) + LDANN _f -> cpu & a .~ fetch cpu _f + LDNNA _t -> write cpu _t $ cpu ^. a + LDHAC -> let target = 65280 + (fromIntegral $ cpu ^. c) value = fetch cpu target in - cpu & registers . a .~ value - LDHCA -> let target = 65280 + (fromIntegral $ cpu ^. registers . c) in - write cpu target $ cpu ^. registers . a + cpu & a .~ value + LDHCA -> let target = 65280 + (fromIntegral $ cpu ^. c) in + write cpu target $ cpu ^. a LDHAN v -> let target = 65280 + (fromIntegral v) value = fetch cpu target in - cpu & registers . a .~ value + cpu & a .~ value LDHNA v -> let target = 65280 + (fromIntegral v) in - write cpu target $ cpu ^. registers . a - LDAHL op -> let target = cpu ^. registers . hl + write cpu target $ cpu ^. a + LDAHL op -> let target = cpu ^. hl value = fetch cpu target in - cpu & registers . a .~ value - & registers . hl %~ op - LDHLA op -> let target = cpu ^. registers . hl in - write cpu target (cpu ^. registers . a) - & registers . hl %~ op + cpu & a .~ value + & hl %~ op + LDHLA op -> let target = cpu ^. hl in + write cpu target (cpu ^. a) + & hl %~ op LDRRNN t v -> cpu & t .~ v LDNNSP v -> write cpu v . fetch cpu $ cpu ^. sp - LDSPHL -> cpu & sp .~ cpu ^. registers . hl + LDSPHL -> cpu & sp .~ cpu ^. hl PUSHRR t -> let cpu' = cpu & sp %~ subtract 1 msb = fromIntegral $ (cpu ^. t) .>>. 4 lsb = fromIntegral $ (cpu ^. t) .&. 255 @@ -386,8 +405,8 @@ execute cpu = \case & sp %~ (+1) LDHLSPE v -> let value = cpu ^. sp newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral v) in - cpu & registers . hl .~ value - & registers . flags .~ + cpu & hl .~ value + & flags .~ FlagRegister { _zero = False, _negative = False, _halfCarry = value .&. 16 + fromIntegral v .&. 16 > 16, -- TODO: check if this still works out