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

Mjau

Browse Source
This commit is contained in:
pingu
2026-04-01 11:19:41 +02:00
parent 47aedfdd8e
commit a69d0c9342
5 changed files with 65 additions and 34 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/GB.hs → src/GBC.hs
View File

@@ -1,3 +1,3 @@
{-# LANGUAGE TemplateHaskell
, RecordWildCards #-}
module GB where
module GBC where

87
src/GB/CPU.hs → src/GBC/CPU.hs
View File

@@ -3,7 +3,7 @@
, DataKinds
, FlexibleContexts
, GADTs #-}
module GB.CPU where
module GBC.CPU where
import Lens.Micro.Platform
import Data.Word
@@ -34,17 +34,17 @@ carryFlagPosition = 4
instance Convert FlagRegister Word8 where
convert r =
((`shiftL` zeroFlagPosition) $ if r ^. zero then 1 else 0) +
((`shiftL` negativeFlagPosition) $ if r ^. negative then 1 else 0) +
((`shiftL` halfCarryFlagPosition) $ if r ^. halfCarry then 1 else 0) +
((`shiftL` carryFlagPosition) $ if r ^. carry then 1 else 0)
((.<<. 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)
instance Convert Word8 FlagRegister where
convert w =
let _zero = (shiftR w zeroFlagPosition .&. 1 /= 0)
_negative = (shiftR w negativeFlagPosition .&. 1 /= 0)
_halfCarry = (shiftR w halfCarryFlagPosition .&. 1 /= 0)
_carry = (shiftR w carryFlagPosition .&. 1 /= 0) in
let _zero = (w `testBit` zeroFlagPosition)
_negative = (w `testBit` negativeFlagPosition)
_halfCarry = (w `testBit` halfCarryFlagPosition)
_carry = (w `testBit` carryFlagPosition) in
FlagRegister {..}
@@ -118,6 +118,11 @@ data Instruction where
RR :: ArithmeticTarget -> Instruction
RRHL :: Instruction
SLA :: ArithmeticTarget -> Instruction
SLAHL :: Instruction
SRA :: ArithmeticTarget -> Instruction
SRAHL :: Instruction
execute :: CPU -> Instruction -> CPU
execute cpu = \case
AddR t _c -> let value = cpu ^. registers . t
@@ -197,69 +202,91 @@ execute cpu = \case
(newValue, newFlags) = add16 _hl _bc _flags in
cpu & registers . hl .~ newValue
& registers . flags .~ newFlags
AddSP e -> let value = cpu ^. sp
newValue :: Word16 = fromIntegral (fromIntegral value) + (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,
_negative = False,
_halfCarry = value .&. 16 + fromIntegral e .&. 16 > 16, -- TODO: check if this still works out
_halfCarry = value .&. 16 + fromIntegral _e .&. 16 > 16, -- TODO: check if this still works out
_carry = value > newValue
}
RLCA -> let _carry = cpu ^. registers . a .&. 128 == 128 in
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 .&. 1 == 1 in
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 .&. 128 == 128
RLA -> let _carry = (cpu ^. registers . a) `testBit` 8
_c = cpu ^. registers . flags . carry in
cpu & registers . a %~ (if _c then (+1) else id) . (`shiftL` 1)
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 .&. 1 == 1
RRA -> let _carry = (cpu ^. registers . a) `testBit` 1
_c = cpu ^. registers . flags . carry in
cpu & registers . a %~ (if _c then (+128) else id) . (`shiftR` 1)
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 .&. 128 == 128
RLC t -> let _carry = (cpu ^. registers . t) `testBit` 8
newValue = cpu ^. registers . t `rotateL` 1 in
cpu & registers . t .~ newValue
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RLCHL -> let target = cpu ^. registers . hl
value = fetch cpu target
_carry = value .&. 128 == 128
_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 .&. 1 == 1
RRC t -> let _carry = (cpu ^. registers . t) `testBit` 1
newValue = cpu ^. registers . t `rotateR` 1 in
cpu & registers . t .~ newValue
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RRCHL -> let target = cpu ^. registers . hl
value = fetch cpu target
_carry = value .&. 1 == 1
_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 .&. 128 == 128
RL t -> let _carry = (cpu ^. registers . t) `testBit` 8
_c = cpu ^. registers . flags . carry
newValue = (if _c then (+1) else id) $ cpu ^. registers . t `shiftL` 1 in
newValue = (if _c then (+1) else id) $ cpu ^. registers . t .<<. 1 in
cpu & registers . t .~ newValue
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RLHL -> let target = cpu ^. registers . hl
value = fetch cpu target
_c = cpu ^. registers . flags . carry
_carry = value .&. 128 == 128
newValue = (if _c then (+1) else id) $ value `shiftL` 1 in
_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 .&. 1 == 1
RR t -> let _carry = (cpu ^. registers . t) `testBit` 1
_c = cpu ^. registers . flags . carry
newValue = (if _c then (+128) else id) $ cpu ^. registers . t `shiftR` 1 in
newValue = (if _c then (+128) else id) $ cpu ^. registers . t .>>. 1 in
cpu & registers . t .~ newValue
& registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
RRHL -> let target = cpu ^. registers . hl
value = fetch cpu target
_c = cpu ^. registers . flags . carry
_carry = value .&. 1 == 1
newValue = (if _c then (+128) else id) $ value `shiftR` 1 in
_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
in
cpu & registers . 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, ..}
SRA t -> let _carry = (cpu ^. registers . t) `testBit` 1
value = cpu ^. registers . t
newValue = let temp = value .>>. 1 in if value `testBit` 8 then temp `setBit` 8 else temp
in
cpu & registers . t .~ newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
SRAHL -> let target = cpu ^. registers . hl
value = fetch cpu target
newValue = let temp = value .>>. 1 in if value `testBit` 8 then temp `setBit` 8 else temp
_carry = value `testBit` 8
in
write cpu target newValue & registers . flags .~ FlagRegister {_zero = newValue == 0, _negative = False, _halfCarry = False, ..}
where
add :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister)
add o n _c = let new = o + n + if _c then 1 else 0