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

Mjapp

Browse Source
This commit is contained in:
pingu
2026-04-07 17:03:04 +02:00
parent 9843466b4f
commit 71fbf52e4a
2 changed files with 178 additions and 76 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
Tia.cabal
View File

@@ -71,6 +71,7 @@ library
build-depends: base ^>=4.20.2.0 build-depends: base ^>=4.20.2.0
, microlens-platform , microlens-platform
, vector-sized , vector-sized
, lattices
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: src hs-source-dirs: src

247
src/GBC/CPU.hs
View File

@@ -10,6 +10,7 @@ import Data.Word
import Data.Bits import Data.Bits
import Data.Int import Data.Int
import qualified Data.Vector.Sized as V import qualified Data.Vector.Sized as V
import Algebra.Lattice
splitWord :: Word16 -> (Word8, Word8) splitWord :: Word16 -> (Word8, Word8)
splitWord w = (fromIntegral $ w .>>. 8, fromIntegral $ w .&. 255) splitWord w = (fromIntegral $ w .>>. 8, fromIntegral $ w .&. 255)
@@ -211,87 +212,141 @@ data Instruction where
EI :: Instruction EI :: Instruction
NOP :: Instruction NOP :: Instruction
execute :: CPU -> Instruction -> CPU data Exec a b c = Done c | Await a (b -> Exec a b c)
instance Functor (Exec a b) where
fmap f (Done a) = Done $ f a
fmap f (Await n g) = Await n (\a -> f <$> g a)
instance Lattice a => Applicative (Exec a b) where
pure = Done
(Done f) <*> fa = f <$> fa
(Await n f) <*> (Done a) = Await n $ \b -> case f b of
Done f -> Done $ f a
ff -> ff <*> Done a
(Await n f) <*> (Await n' g) = Await (n \/ n') $ \a -> f a <*> g a
instance Lattice a => Monad (Exec a b) where
Done a >>= f = f a
Await n g >>= f = Await n $ \b -> case g b of
Done a -> f a
ff -> ff >>= f
data Status where
Running :: Status
Halted :: Status
instance Lattice Status where
Running \/ Halted = Halted
Halted \/ Running = Halted
f \/ _ = f
Running /\ Halted = Running
Halted /\ Running = Running
f /\ _ = f
execute :: CPU -> Instruction -> Exec Status CPU CPU
execute cpu = \case execute cpu = \case
ADDR t _c -> let value = cpu ^. t ADDR t _c -> let value = cpu ^. t
(newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
ADDHL _c -> let value = fetch cpu $ cpu ^. hl ADDHL _c -> let value = fetch cpu $ cpu ^. hl
(newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
ADDN value _c -> let (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in ADDN value _c -> let (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
SUBR t _c -> let value = cpu ^. t SUBR t _c -> let value = cpu ^. t
(newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
SUBHL _c -> let value = fetch cpu $ cpu ^. hl SUBHL _c -> let value = fetch cpu $ cpu ^. hl
(newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
SUBN value _c -> let (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in SUBN value _c -> let (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
CPR t -> let value = cpu ^. t CPR t -> let value = cpu ^. t
(_, newFlags) = sub (cpu ^. a) value $ False in (_, newFlags) = sub (cpu ^. a) value $ False in
pure $
cpu & flags .~ newFlags cpu & flags .~ newFlags
CPHL -> let value = fetch cpu $ cpu ^. hl CPHL -> let value = fetch cpu $ cpu ^. hl
(_, newFlags) = sub (cpu ^. a) value $ False in (_, newFlags) = sub (cpu ^. a) value $ False in
pure $
cpu & flags .~ newFlags cpu & flags .~ newFlags
CPN value -> let (_, newFlags) = sub (cpu ^. a) value $ False in CPN value -> let (_, newFlags) = sub (cpu ^. a) value $ False in
pure $
cpu & flags .~ newFlags cpu & flags .~ newFlags
INCR t -> let (value, newFlags) = add (cpu ^. t) 1 False in INCR t -> let (value, newFlags) = add (cpu ^. t) 1 False in
pure $
cpu & t .~ value cpu & t .~ value
& flags .~ newFlags & flags .~ newFlags
INCHL -> let target = cpu ^. hl INCHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
(newValue, newFlags) = add value 1 False in (newValue, newFlags) = add value 1 False in
pure $
write cpu target newValue & flags .~ newFlags write cpu target newValue & flags .~ newFlags
DECR t -> let (value, newFlags) = sub (cpu ^. t) 1 False in DECR t -> let (value, newFlags) = sub (cpu ^. t) 1 False in
pure $
cpu & t .~ value cpu & t .~ value
& flags .~ newFlags & flags .~ newFlags
DECHL -> let target = cpu ^. hl DECHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
(newValue, newFlags) = sub value 1 False in (newValue, newFlags) = sub value 1 False in
pure $
write cpu target newValue & flags .~ newFlags write cpu target newValue & flags .~ newFlags
BOR t op _f -> let newValue = (cpu ^. a) `op` (cpu ^. t) BOR t op _f -> let newValue = (cpu ^. a) `op` (cpu ^. t)
newFlags = _f {_fZero = newValue == 0} in newFlags = _f {_fZero = newValue == 0} in
pure $
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
BOHL op _f -> let target = cpu ^. hl BOHL op _f -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
newValue = (cpu ^. a) `op` value newValue = (cpu ^. a) `op` value
newFlags = _f {_fZero = value == 0} in newFlags = _f {_fZero = value == 0} in
pure $
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
BON value op _f -> let newValue = (cpu ^. a) `op` value BON value op _f -> let newValue = (cpu ^. a) `op` value
newFlags = _f {_fZero = newValue == 0} in newFlags = _f {_fZero = newValue == 0} in
pure $
cpu & a .~ newValue cpu & a .~ newValue
& flags .~ newFlags & flags .~ newFlags
CCF -> cpu & negative .~ False CCF -> pure $
& halfCarry .~ False cpu & negative .~ False
& carry %~ not & halfCarry .~ False
SCF -> cpu & negative .~ False & carry %~ not
& halfCarry .~ False SCF -> pure $
& carry .~ True cpu & negative .~ False
& halfCarry .~ False
& carry .~ True
DAA -> undefined -- TODO: undefined in manual DAA -> undefined -- TODO: undefined in manual
CPL -> cpu & a %~ complement CPL -> pure $
& negative .~ True cpu & a %~ complement
& halfCarry .~ True & negative .~ True
INCRR -> cpu & bc %~ (+1) & halfCarry .~ True
DECRR -> cpu & bc %~ (+1) INCRR -> pure $ cpu & bc %~ (+1)
DECRR -> pure $ cpu & bc %~ (+1)
ADDHLRR t -> let _flags = cpu ^. flags ADDHLRR t -> let _flags = cpu ^. flags
_hl = cpu ^. hl _hl = cpu ^. hl
val = cpu ^. t val = cpu ^. t
(newValue, newFlags) = add16 _hl val _flags in (newValue, newFlags) = add16 _hl val _flags in
pure $
cpu & hl .~ newValue cpu & hl .~ newValue
& flags .~ newFlags & flags .~ newFlags
ADDSP _e -> let value = cpu ^. sp ADDSP _e -> let value = cpu ^. sp
newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral _e) in newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral _e) in
pure $
cpu & sp .~ newValue cpu & sp .~ newValue
& flags .~ & flags .~
FlagRegister { _fZero = False, FlagRegister { _fZero = False,
@@ -300,144 +355,169 @@ execute cpu = \case
_fCarry = value > newValue _fCarry = value > newValue
} }
RLCA -> let _fCarry = (cpu ^. a) `testBit` 8 in RLCA -> let _fCarry = (cpu ^. a) `testBit` 8 in
cpu & a %~ (`rotateL` 1) pure $
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..} cpu & a %~ (`rotateL` 1)
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RRCA -> let _fCarry = (cpu ^. a) `testBit` 1 in RRCA -> let _fCarry = (cpu ^. a) `testBit` 1 in
cpu & a %~ (`rotateR` 1) pure $
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..} cpu & a %~ (`rotateR` 1)
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RLA -> let _fCarry = (cpu ^. a) `testBit` 8 RLA -> let _fCarry = (cpu ^. a) `testBit` 8
_c = cpu ^. carry in _c = cpu ^. carry in
cpu & a %~ (if _c then (+1) else id) . (.<<. 1) pure $
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..} cpu & a %~ (if _c then (+1) else id) . (.<<. 1)
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RRA -> let _fCarry = (cpu ^. a) `testBit` 1 RRA -> let _fCarry = (cpu ^. a) `testBit` 1
_c = cpu ^. carry in _c = cpu ^. carry in
cpu & a %~ (if _c then (+128) else id) . (.>>. 1) pure $
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..} cpu & a %~ (if _c then (+128) else id) . (.>>. 1)
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RLC t -> let _fCarry = (cpu ^. t) `testBit` 8 RLC t -> let _fCarry = (cpu ^. t) `testBit` 8
newValue = cpu ^. t `rotateL` 1 in newValue = cpu ^. t `rotateL` 1 in
cpu & t .~ newValue pure $
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RLCHL -> let target = cpu ^. hl RLCHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
_fCarry = (value) `testBit` 8 _fCarry = (value) `testBit` 8
newValue = value `rotateL` 1 in newValue = value `rotateL` 1 in
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} pure $
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RRC t -> let _fCarry = (cpu ^. t) `testBit` 1 RRC t -> let _fCarry = (cpu ^. t) `testBit` 1
newValue = cpu ^. t `rotateR` 1 in newValue = cpu ^. t `rotateR` 1 in
cpu & t .~ newValue pure $
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RRCHL -> let target = cpu ^. hl RRCHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
_fCarry = value `testBit` 1 _fCarry = value `testBit` 1
newValue = value `rotateR` 1 in newValue = value `rotateR` 1 in
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} pure $
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RL t -> let _fCarry = (cpu ^. t) `testBit` 8 RL t -> let _fCarry = (cpu ^. t) `testBit` 8
_c = cpu ^. carry _c = cpu ^. carry
newValue = (if _c then (+1) else id) $ cpu ^. t .<<. 1 in newValue = (if _c then (+1) else id) $ cpu ^. t .<<. 1 in
cpu & t .~ newValue pure $
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RLHL -> let target = cpu ^. hl RLHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
_c = cpu ^. carry _c = cpu ^. carry
_fCarry = value `testBit` 8 _fCarry = value `testBit` 8
newValue = (if _c then (+1) else id) $ value .<<. 1 in newValue = (if _c then (+1) else id) $ value .<<. 1 in
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} pure $
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RR t -> let _fCarry = (cpu ^. t) `testBit` 1 RR t -> let _fCarry = (cpu ^. t) `testBit` 1
_c = cpu ^. carry _c = cpu ^. carry
newValue = (if _c then (+128) else id) $ cpu ^. t .>>. 1 in newValue = (if _c then (+128) else id) $ cpu ^. t .>>. 1 in
cpu & t .~ newValue pure $
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RRHL -> let target = cpu ^. hl RRHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
_c = cpu ^. carry _c = cpu ^. carry
_fCarry = value `testBit` 1 _fCarry = value `testBit` 1
newValue = (if _c then (+128) else id) $ value .>>. 1 in newValue = (if _c then (+128) else id) $ value .>>. 1 in
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} pure $
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SLA t -> let _fCarry = (cpu ^. t) `testBit` 8 SLA t -> let _fCarry = (cpu ^. t) `testBit` 8
newValue = cpu ^. t .<<. 1 newValue = cpu ^. t .<<. 1
in in
pure $
cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SLAHL -> let target = cpu ^. hl SLAHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
newValue = value .<<. 1 newValue = value .<<. 1
_fCarry = value `testBit` 8 _fCarry = value `testBit` 8
in in
pure $
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SR t arith -> let _fCarry = (cpu ^. t) `testBit` 1 SR t arith -> let _fCarry = (cpu ^. t) `testBit` 1
value = cpu ^. t value = cpu ^. t
newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp
in in
pure $
cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SRHL arith -> let target = cpu ^. hl SRHL arith -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp newValue = let temp = value .>>. 1 in if value `testBit` 8 && arith then temp `setBit` 8 else temp
_fCarry = value `testBit` 1 in _fCarry = value `testBit` 1 in
pure $
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..} write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SWAP t -> let newValue = cpu ^. t `rotateR` 4 in SWAP t -> let newValue = cpu ^. t `rotateR` 4 in
pure $
cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, _fCarry = False} cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, _fCarry = False}
SWAPHL -> let target = cpu ^. hl SWAPHL -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
newValue = value `rotateR` 4 in newValue = value `rotateR` 4 in
pure $
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, _fCarry = False} write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, _fCarry = False}
BIT t i -> let value = cpu ^. t in BIT t i -> let value = cpu ^. t in
cpu & flags %~ (\_f -> _f { _fZero = not $ value `testBit` i, _fNegative = False, _fHalfCarry = True }) pure $
cpu & flags %~ (\_f -> _f { _fZero = not $ value `testBit` i, _fNegative = False, _fHalfCarry = True })
BITHL i -> let target = cpu ^. hl BITHL i -> let target = cpu ^. hl
value = fetch cpu target in value = fetch cpu target in
cpu & flags %~ (\_f -> _f { _fZero = not $ value `testBit` i, _fNegative = False, _fHalfCarry = True }) pure $
RES t i -> cpu & t %~ (`clearBit` i) cpu & flags %~ (\_f -> _f { _fZero = not $ value `testBit` i, _fNegative = False, _fHalfCarry = True })
RES t i -> pure $ cpu & t %~ (`clearBit` i)
RESHL i -> let target = cpu ^. hl RESHL i -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
newValue = value `clearBit` i in newValue = value `clearBit` i in
pure $
write cpu target newValue write cpu target newValue
SET t i -> cpu & t %~ (`setBit` i) SET t i -> pure $ cpu & t %~ (`setBit` i)
SETHL i -> let target = cpu ^. hl SETHL i -> let target = cpu ^. hl
value = fetch cpu target value = fetch cpu target
newValue = value `setBit` i in newValue = value `setBit` i in
write cpu target newValue pure $ write cpu target newValue
LDRR t _f -> cpu & t .~ cpu ^. _f LDRR t _f -> pure $ cpu & t .~ cpu ^. _f
LDRN t v -> cpu & t .~ v LDRN t v -> pure $ cpu & t .~ v
LDRHL t -> let target = cpu ^. hl LDRHL t -> let target = cpu ^. hl
value = fetch cpu target in value = fetch cpu target in
cpu & t .~ value pure $ cpu & t .~ value
LDXR t _f -> let target = cpu ^. t in LDXR t _f -> let target = cpu ^. t in
write cpu target $ cpu ^. _f pure $ write cpu target $ cpu ^. _f
LDXN t v -> let target = cpu ^. t in LDXN t v -> let target = cpu ^. t in
write cpu target v pure $ write cpu target v
LDANN _f -> cpu & a .~ fetch cpu _f LDANN _f -> pure $ cpu & a .~ fetch cpu _f
LDNNA _t -> write cpu _t $ cpu ^. a LDNNA _t -> pure $ write cpu _t $ cpu ^. a
LDHAC -> let target = 65280 + (fromIntegral $ cpu ^. c) LDHAC -> let target = 65280 + (fromIntegral $ cpu ^. c)
value = fetch cpu target in value = fetch cpu target in
cpu & a .~ value pure $ cpu & a .~ value
LDHCA -> let target = 65280 + (fromIntegral $ cpu ^. c) in LDHCA -> let target = 65280 + (fromIntegral $ cpu ^. c) in
write cpu target $ cpu ^. a pure $ write cpu target $ cpu ^. a
LDHAN v -> let target = 65280 + (fromIntegral v) LDHAN v -> let target = 65280 + (fromIntegral v)
value = fetch cpu target in value = fetch cpu target in
cpu & a .~ value pure $ cpu & a .~ value
LDHNA v -> let target = 65280 + (fromIntegral v) in LDHNA v -> let target = 65280 + (fromIntegral v) in
write cpu target $ cpu ^. a pure $ write cpu target $ cpu ^. a
LDAHL op -> let target = cpu ^. hl LDAHL op -> let target = cpu ^. hl
value = fetch cpu target in value = fetch cpu target in
cpu & a .~ value pure $
& hl %~ op cpu & a .~ value
& hl %~ op
LDHLA op -> let target = cpu ^. hl in LDHLA op -> let target = cpu ^. hl in
write cpu target (cpu ^. a) pure $
& hl %~ op write cpu target (cpu ^. a)
LDRRNN t v -> cpu & t .~ v & hl %~ op
LDNNSP v -> write cpu v . fetch cpu $ cpu ^. sp LDRRNN t v -> pure $ cpu & t .~ v
LDSPHL -> cpu & sp .~ cpu ^. hl LDNNSP v -> pure $ write cpu v . fetch cpu $ cpu ^. sp
LDSPHL -> pure $ cpu & sp .~ cpu ^. hl
PUSHRR t -> let cpu' = cpu & sp %~ subtract 1 PUSHRR t -> let cpu' = cpu & sp %~ subtract 1
(msb, lsb) = splitWord $ cpu ^. t (msb, lsb) = splitWord $ cpu ^. t
cpu'' = write cpu' (cpu' ^. sp) msb & sp %~ subtract 1 in cpu'' = write cpu' (cpu' ^. sp) msb & sp %~ subtract 1 in
write cpu'' (cpu'' ^. sp) lsb pure $ write cpu'' (cpu'' ^. sp) lsb
POPRR t -> let lsb = fetch cpu (cpu ^. sp) POPRR t -> let lsb = fetch cpu (cpu ^. sp)
cpu' = cpu & sp %~ (+1) cpu' = cpu & sp %~ (+1)
msb = fetch cpu' (cpu' ^. sp) msb = fetch cpu' (cpu' ^. sp)
value = combineWords msb lsb value = combineWords msb lsb
in in
cpu & t .~ value pure $
& sp %~ (+1) cpu & t .~ value
& sp %~ (+1)
LDHLSPE v -> let value = cpu ^. sp LDHLSPE v -> let value = cpu ^. sp
newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral v) in newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral v) in
pure $
cpu & hl .~ value cpu & hl .~ value
& flags .~ & flags .~
FlagRegister { _fZero = False, FlagRegister { _fZero = False,
@@ -445,39 +525,60 @@ execute cpu = \case
_fHalfCarry = value .&. 16 + fromIntegral v .&. 16 > 16, -- TODO: check if this still works out _fHalfCarry = value .&. 16 + fromIntegral v .&. 16 > 16, -- TODO: check if this still works out
_fCarry = value > newValue _fCarry = value > newValue
} }
JPNN v -> cpu & pc .~ v JPNN v -> pure $ cpu & pc .~ v
JPHL -> cpu & pc .~ cpu ^. hl JPHL -> pure $ cpu & pc .~ cpu ^. hl
JPCCNN v _f op -> if op $ cpu ^. _f then cpu & pc .~ v else cpu JPCCNN v _f op -> pure $ if op $ cpu ^. _f then cpu & pc .~ v else cpu
JRE v -> let target = fromIntegral $ (fromIntegral (cpu ^. pc) :: Integer) + fromIntegral v in cpu & pc .~ target JRE v -> let target = fromIntegral $ (fromIntegral (cpu ^. pc) :: Integer) + fromIntegral v in pure $ cpu & pc .~ target
JRCCE v _f op -> if op $ cpu ^. _f then JRCCE v _f op -> pure $ if op $ cpu ^. _f then
let target = fromIntegral $ (fromIntegral (cpu ^. pc) :: Integer) + fromIntegral v in let target = fromIntegral $ (fromIntegral (cpu ^. pc) :: Integer) + fromIntegral v in
cpu & pc .~ target cpu & pc .~ target
else else
cpu cpu
CALLNN v -> undefined CALLNN v -> let (msb,lsb) = splitWord $ cpu ^. pc
CALLCCNN v _f op -> undefined cpu' = cpu & sp %~ subtract 1
cpu'' = (write cpu' (cpu' ^. sp) msb) & sp %~ subtract 1
cpu''' = (write cpu'' (cpu'' ^. sp) lsb) in
pure $ cpu''' & pc .~ v
CALLCCNN v _f op -> pure $ if op $ cpu ^. _f then
let (msb,lsb) = splitWord $ cpu ^. pc
cpu' = cpu & sp %~ subtract 1
cpu'' = (write cpu' (cpu' ^. sp) msb) & sp %~ subtract 1
cpu''' = (write cpu'' (cpu'' ^. sp) lsb) in
cpu''' & pc .~ v
else
cpu
RET -> let lsb = fetch cpu (cpu ^. sp) RET -> let lsb = fetch cpu (cpu ^. sp)
cpu' = cpu & sp %~ (+1) cpu' = cpu & sp %~ (+1)
msb = fetch cpu' (cpu' ^. sp) msb = fetch cpu' (cpu' ^. sp)
value = combineWords msb lsb in value = combineWords msb lsb in
cpu & pc .~ value pure $ cpu' & pc .~ value
& ie .~ 1 & ie .~ 1
RETCC _f op -> undefined & sp %~ (+1)
RETCC _f op -> pure $ if op $ cpu ^. _f then
let lsb = fetch cpu (cpu ^. sp)
cpu' = cpu & sp %~ (+1)
msb = fetch cpu' (cpu' ^. sp)
value = combineWords msb lsb in
cpu' & pc .~ value
& ie .~ 1
& sp %~ (+1)
else cpu
RETI -> let lsb = fetch cpu (cpu ^. sp) RETI -> let lsb = fetch cpu (cpu ^. sp)
cpu' = cpu & sp %~ (+1) cpu' = cpu & sp %~ (+1)
msb = fetch cpu' (cpu' ^. sp) msb = fetch cpu' (cpu' ^. sp)
value = combineWords msb lsb in value = combineWords msb lsb in
pure $
cpu & pc .~ value cpu & pc .~ value
& ie .~ 1 & ie .~ 1
RSTN v -> let cpu' = cpu & sp %~ subtract 1 RSTN v -> let cpu' = cpu & sp %~ subtract 1
(msb,lsb) = splitWord $ cpu ^. pc (msb,lsb) = splitWord $ cpu ^. pc
cpu'' = write cpu' (cpu' ^. sp) msb & sp %~ subtract 1 in cpu'' = write cpu' (cpu' ^. sp) msb & sp %~ subtract 1 in
write cpu'' (cpu'' ^. sp) lsb & pc .~ v pure $ write cpu'' (cpu'' ^. sp) lsb & pc .~ v
HALT -> undefined HALT -> Await Halted pure
STOP -> undefined STOP -> undefined
DI -> cpu & ie .~ 0 DI -> pure $ cpu & ie .~ 0
EI -> cpu & ie .~ 1 EI -> pure $ cpu & ie .~ 1
NOP -> cpu NOP -> pure $ cpu
where where
add :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister) add :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister)
add o n _c = let new = o + n + if _c then 1 else 0 add o n _c = let new = o + n + if _c then 1 else 0