diff --git a/src/GBC/CPU.hs b/src/GBC/CPU.hs index 0106b5c..f0018b0 100644 --- a/src/GBC/CPU.hs +++ b/src/GBC/CPU.hs @@ -66,6 +66,10 @@ 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)) +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)) + 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)) @@ -76,23 +80,24 @@ data CPU = CPU { _registers :: Registers , _bus :: (V.Vector 65536 Word8) } makeLenses ''CPU -type ArithmeticTarget = Lens' Registers Word8 +type ByteTarget = Lens' CPU Word8 +type WordTarget = Lens' CPU Word16 data Instruction where - AddR :: { t :: ArithmeticTarget, withCarry :: Bool } -> Instruction - AddHL :: { withCarry :: Bool } -> Instruction - AddN :: { val :: Word8, withCarry :: Bool } -> Instruction - SubR :: { t :: ArithmeticTarget, withCarry :: Bool } -> Instruction - SubHL :: { withCarry :: Bool } -> Instruction - SubN :: { val :: Word8, withCarry :: Bool } -> Instruction - CpR :: { t :: ArithmeticTarget } -> Instruction - CpHL :: Instruction - CpN :: { val :: Word8 } -> Instruction - IncR :: { t :: ArithmeticTarget } -> Instruction - IncHL :: Instruction - DecR :: { t :: ArithmeticTarget } -> Instruction - DecHL :: Instruction - BOR :: { t :: ArithmeticTarget, op :: (Word8 -> Word8 -> Word8), fr :: FlagRegister } -> Instruction + ADDR :: { t :: ByteTarget, withCarry :: Bool } -> Instruction + ADDHL :: { withCarry :: Bool } -> Instruction + ADDN :: { val :: Word8, withCarry :: Bool } -> Instruction + SUBR :: { t :: ByteTarget, withCarry :: Bool } -> Instruction + SUBHL :: { withCarry :: Bool } -> Instruction + SUBN :: { val :: Word8, withCarry :: Bool } -> Instruction + CPR :: { t :: ByteTarget } -> Instruction + CPHL :: Instruction + CPN :: { val :: Word8 } -> Instruction + INCR :: { t :: ByteTarget } -> Instruction + INCHL :: Instruction + DECR :: { t :: ByteTarget } -> Instruction + DECHL :: Instruction + BOR :: { t :: ByteTarget, op :: (Word8 -> Word8 -> Word8), fr :: FlagRegister } -> Instruction BOHL :: { op :: (Word8 -> Word8 -> Word8), fr :: FlagRegister } -> Instruction BON :: { val :: Word8, op :: (Word8 -> Word8 -> Word8), fr :: FlagRegister } -> Instruction CCF :: Instruction @@ -100,85 +105,106 @@ data Instruction where DAA :: Instruction -- TODO: What does this do? CPL :: Instruction - IncRR :: Instruction - DecRR :: Instruction - AddHLRR :: Instruction - AddSP :: { rel :: Int8 } -> Instruction + INCRR :: Instruction + DECRR :: Instruction + ADDHLRR :: { from' :: WordTarget } -> Instruction + ADDSP :: { rel :: Int8 } -> Instruction RLCA :: Instruction RRCA :: Instruction RLA :: Instruction RRA :: Instruction - RLC :: { t :: ArithmeticTarget } -> Instruction + RLC :: { t :: ByteTarget } -> Instruction RLCHL :: Instruction - RRC :: { t :: ArithmeticTarget } -> Instruction + RRC :: { t :: ByteTarget } -> Instruction RRCHL :: Instruction - RL :: { t :: ArithmeticTarget } -> Instruction + RL :: { t :: ByteTarget } -> Instruction RLHL :: Instruction - RR :: { t :: ArithmeticTarget } -> Instruction + RR :: { t :: ByteTarget } -> Instruction RRHL :: Instruction - SLA :: { t :: ArithmeticTarget } -> Instruction + SLA :: { t :: ByteTarget } -> Instruction SLAHL :: Instruction - SR :: { t :: ArithmeticTarget, arithmetic :: Bool } -> Instruction + SR :: { t :: ByteTarget, arithmetic :: Bool } -> Instruction SRHL :: { arithmetic :: Bool } -> Instruction - SWAP :: { t :: ArithmeticTarget } -> Instruction + SWAP :: { t :: ByteTarget } -> Instruction SWAPHL :: Instruction - BIT :: { t :: ArithmeticTarget, bit :: Int } -> Instruction + BIT :: { t :: ByteTarget, bit :: Int } -> Instruction BITHL :: { bit :: Int } -> Instruction - RES :: { t :: ArithmeticTarget, bit :: Int } -> Instruction + RES :: { t :: ByteTarget, bit :: Int } -> Instruction RESHL :: { bit :: Int } -> Instruction - SET :: { t :: ArithmeticTarget, bit :: Int } -> Instruction + SET :: { t :: ByteTarget, bit :: Int } -> Instruction SETHL :: { bit :: Int } -> Instruction + LDRR :: { to :: ByteTarget, from :: ByteTarget } -> Instruction + LDRN :: { to :: ByteTarget, val :: Word8 } -> Instruction + LDRHL :: { to :: ByteTarget } -> Instruction + LDXR :: { to' :: WordTarget, from :: ByteTarget } -> Instruction + LDXN :: { to' :: WordTarget, val :: Word8 } -> Instruction + LDANN :: { from'' :: Word16 } -> Instruction + LDNNA :: { to'' :: Word16 } -> Instruction + LDHAC :: Instruction + LDHCA :: Instruction + LDHAN :: { val :: Word8 } -> Instruction + LDHNA :: { val :: Word8 } -> Instruction + LDAHL :: { op' :: (Word16 -> Word16) } -> Instruction + LDHLA :: { op' :: (Word16 -> Word16) } -> Instruction + + LDRRNN :: { to' :: WordTarget, val' :: Word16} -> Instruction + LDNNSP :: { val' :: Word16 } -> Instruction + LDSPHL :: Instruction + PUSHRR :: { from' :: WordTarget } -> Instruction + POPRR :: { to' :: WordTarget } -> Instruction + LDHLSPE :: { rel :: Int8 } -> Instruction + execute :: CPU -> Instruction -> CPU execute cpu = \case - AddR t _c -> let value = cpu ^. registers . t + 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 + 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 + 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 + 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 + 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 + 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 -> let value = cpu ^. registers . t + 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 + 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 + CPN value -> let (_, newFlags) = sub (cpu ^. registers . a) value $ False in cpu & registers . flags .~ newFlags - IncR t -> let (value, newFlags) = add (cpu ^. registers . t) 1 False in - cpu & registers . t .~ value + INCR t -> let (value, newFlags) = add (cpu ^. t) 1 False in + cpu & t .~ value & registers . flags .~ newFlags - IncHL -> let target = cpu ^. registers . hl + 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 + DECR t -> let (value, newFlags) = sub (cpu ^. t) 1 False in + cpu & t .~ value & registers . flags .~ newFlags - DecHL -> let target = cpu ^. registers . hl + 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) + BOR t op _f -> let newValue = (cpu ^. registers . a) `op` (cpu ^. t) newFlags = _f {_zero = newValue == 0} in cpu & registers . a .~ newValue & registers . flags .~ newFlags @@ -203,16 +229,16 @@ execute cpu = \case 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 + INCRR -> cpu & registers . bc %~ (+1) + DECRR -> cpu & registers . bc %~ (+1) + ADDHLRR t -> let _flags = cpu ^. registers . flags + _hl = cpu ^. registers . hl + val = cpu ^. t + (newValue, newFlags) = add16 _hl val _flags in cpu & registers . hl .~ newValue & registers . flags .~ newFlags - AddSP _e -> let value = cpu ^. sp - newValue :: Word16 = fromIntegral (fromIntegral value :: Integer) + (fromIntegral _e) in + ADDSP _e -> let value = cpu ^. sp + newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral _e) in cpu & sp .~ newValue & registers . flags .~ FlagRegister { _zero = False, @@ -234,28 +260,28 @@ execute cpu = \case _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 + 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 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 + 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 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 + RL t -> let _carry = (cpu ^. t) `testBit` 8 _c = cpu ^. registers . flags . carry - newValue = (if _c then (+1) else id) $ cpu ^. registers . t .<<. 1 in - cpu & registers . t .~ newValue + 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 value = fetch cpu target @@ -263,10 +289,10 @@ execute cpu = \case _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 + RR t -> let _carry = (cpu ^. t) `testBit` 1 _c = cpu ^. registers . flags . carry - newValue = (if _c then (+128) else id) $ cpu ^. registers . t .>>. 1 in - cpu & registers . t .~ newValue + 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 value = fetch cpu target @@ -274,49 +300,100 @@ execute cpu = \case _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 + SLA t -> let _carry = (cpu ^. t) `testBit` 8 + newValue = cpu ^. t .<<. 1 in - cpu & registers . t .~ newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} + cpu & 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, ..} - SR t arith -> let _carry = (cpu ^. registers . t) `testBit` 1 - value = cpu ^. registers . t + 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 & registers . t .~ newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} + cpu & t .~ newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} SRHL arith -> let target = cpu ^. registers . 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` 8 - in + _carry = value `testBit` 1 in write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..} - SWAP t -> let newValue = cpu ^. registers . t `rotateR` 4 in - cpu & registers . t .~ newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, _carry = 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 value = fetch cpu target - newValue = value `rotateR` 4 - in + newValue = value `rotateR` 4 in write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, _carry = False} - BIT t i -> let value = cpu ^. registers . t in + 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 value = fetch cpu target in cpu & registers . flags %~ (\_f -> _f { _zero = not $ value `testBit` i, _negative = False, _halfCarry = True }) - RES t i -> cpu & registers . t %~ (`clearBit` i) + RES t i -> cpu & t %~ (`clearBit` i) RESHL i -> let target = cpu ^. registers . hl value = fetch cpu target newValue = value `clearBit` i in write cpu target newValue - SET t i -> cpu & registers . t %~ (`setBit` i) + SET t i -> cpu & t %~ (`setBit` i) SETHL i -> let target = cpu ^. registers . 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 + 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) + value = fetch cpu target in + cpu & registers . a .~ value + LDHCA -> let target = 65280 + (fromIntegral $ cpu ^. registers . c) in + write cpu target $ cpu ^. registers . a + LDHAN v -> let target = 65280 + (fromIntegral v) + value = fetch cpu target in + cpu & registers . a .~ value + LDHNA v -> let target = 65280 + (fromIntegral v) in + write cpu target $ cpu ^. registers . a + LDAHL op -> let target = cpu ^. registers . 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 + LDRRNN t v -> cpu & t .~ v + LDNNSP v -> write cpu v . fetch cpu $ cpu ^. sp + LDSPHL -> cpu & sp .~ cpu ^. registers . hl + PUSHRR t -> let cpu' = cpu & sp %~ subtract 1 + msb = fromIntegral $ (cpu ^. t) .>>. 4 + lsb = fromIntegral $ (cpu ^. t) .&. 255 + cpu'' = write cpu' (cpu' ^. sp) msb & sp %~ subtract 1 in + write cpu'' (cpu'' ^. sp) lsb + POPRR t -> let lsb = fetch cpu (cpu ^. sp) + cpu' = cpu & sp %~ (+1) + msb = fetch cpu' (cpu' ^. sp) + value = (fromIntegral msb .<<. 8) + (fromIntegral lsb) + in + cpu & t .~ value + & sp %~ (+1) + LDHLSPE v -> let value = cpu ^. sp + newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral v) in + cpu & registers . hl .~ value + & registers . flags .~ + FlagRegister { _zero = False, + _negative = False, + _halfCarry = value .&. 16 + fromIntegral v .&. 16 > 16, -- TODO: check if this still works out + _carry = value > newValue + } + where add :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister) add o n _c = let new = o + n + if _c then 1 else 0