I breaka the thingies

2026-04-02 11:04:49 +02:00
parent 1fbabc80d3
commit 053bd0bbd9
1 changed files with 157 additions and 80 deletions
--- 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
+  INCRR -> cpu & registers . bc %~ (+1)
+  DECRR -> cpu & registers . bc %~ (+1)
+  ADDHLRR t -> let _flags = cpu ^. registers . flags
                   _hl = cpu ^. registers . hl
-                 _bc = cpu ^. registers . bc
-                 (newValue, newFlags) = add16 _hl _bc _flags in
+                   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