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
, microlens-platform
, vector-sized
, lattices
-- Directories containing source files.
hs-source-dirs: src

253
src/GBC/CPU.hs
View File

@@ -10,6 +10,7 @@ import Data.Word
import Data.Bits
import Data.Int
import qualified Data.Vector.Sized as V
import Algebra.Lattice
splitWord :: Word16 -> (Word8, Word8)
splitWord w = (fromIntegral $ w .>>. 8, fromIntegral $ w .&. 255)
@@ -44,7 +45,7 @@ instance Convert FlagRegister Word8 where
((.<<. negativeFlagPosition) $ if r ^. fNegative then 1 else 0) +
((.<<. halfCarryFlagPosition) $ if r ^. fHalfCarry then 1 else 0) +
((.<<. carryFlagPosition) $ if r ^. fCarry then 1 else 0)
instance Convert Word8 FlagRegister where
convert w =
let _fZero = (w `testBit` zeroFlagPosition)
@@ -211,87 +212,141 @@ data Instruction where
EI :: 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
ADDR t _c -> let value = cpu ^. t
(newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue
& flags .~ newFlags
ADDHL _c -> let value = fetch cpu $ cpu ^. hl
(newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue
& flags .~ newFlags
ADDN value _c -> let (newValue, newFlags) = add (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue
& flags .~ newFlags
SUBR t _c -> let value = cpu ^. t
(newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue
& flags .~ newFlags
SUBHL _c -> let value = fetch cpu $ cpu ^. hl
(newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue
& flags .~ newFlags
SUBN value _c -> let (newValue, newFlags) = sub (cpu ^. a) value $ _c && cpu ^. carry in
pure $
cpu & a .~ newValue
& flags .~ newFlags
CPR t -> let value = cpu ^. t
(_, newFlags) = sub (cpu ^. a) value $ False in
pure $
cpu & flags .~ newFlags
CPHL -> let value = fetch cpu $ cpu ^. hl
(_, newFlags) = sub (cpu ^. a) value $ False in
pure $
cpu & flags .~ newFlags
CPN value -> let (_, newFlags) = sub (cpu ^. a) value $ False in
pure $
cpu & flags .~ newFlags
INCR t -> let (value, newFlags) = add (cpu ^. t) 1 False in
pure $
cpu & t .~ value
& flags .~ newFlags
INCHL -> let target = cpu ^. hl
value = fetch cpu target
(newValue, newFlags) = add value 1 False in
pure $
write cpu target newValue & flags .~ newFlags
DECR t -> let (value, newFlags) = sub (cpu ^. t) 1 False in
pure $
cpu & t .~ value
& flags .~ newFlags
DECHL -> let target = cpu ^. hl
value = fetch cpu target
(newValue, newFlags) = sub value 1 False in
pure $
write cpu target newValue & flags .~ newFlags
BOR t op _f -> let newValue = (cpu ^. a) `op` (cpu ^. t)
newFlags = _f {_fZero = newValue == 0} in
pure $
cpu & a .~ newValue
& flags .~ newFlags
BOHL op _f -> let target = cpu ^. hl
value = fetch cpu target
newValue = (cpu ^. a) `op` value
newFlags = _f {_fZero = value == 0} in
pure $
cpu & a .~ newValue
& flags .~ newFlags
BON value op _f -> let newValue = (cpu ^. a) `op` value
newFlags = _f {_fZero = newValue == 0} in
pure $
cpu & a .~ newValue
& flags .~ newFlags
CCF -> cpu & negative .~ False
& halfCarry .~ False
& carry %~ not
SCF -> cpu & negative .~ False
& halfCarry .~ False
& carry .~ True
CCF -> pure $
cpu & negative .~ False
& halfCarry .~ False
& carry %~ not
SCF -> pure $
cpu & negative .~ False
& halfCarry .~ False
& carry .~ True
DAA -> undefined -- TODO: undefined in manual
CPL -> cpu & a %~ complement
& negative .~ True
& halfCarry .~ True
INCRR -> cpu & bc %~ (+1)
DECRR -> cpu & bc %~ (+1)
CPL -> pure $
cpu & a %~ complement
& negative .~ True
& halfCarry .~ True
INCRR -> pure $ cpu & bc %~ (+1)
DECRR -> pure $ cpu & bc %~ (+1)
ADDHLRR t -> let _flags = cpu ^. flags
_hl = cpu ^. hl
val = cpu ^. t
(newValue, newFlags) = add16 _hl val _flags in
pure $
cpu & hl .~ newValue
& flags .~ newFlags
ADDSP _e -> let value = cpu ^. sp
newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral _e) in
pure $
cpu & sp .~ newValue
& flags .~
FlagRegister { _fZero = False,
@@ -300,144 +355,169 @@ execute cpu = \case
_fCarry = value > newValue
}
RLCA -> let _fCarry = (cpu ^. a) `testBit` 8 in
cpu & a %~ (`rotateL` 1)
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
pure $
cpu & a %~ (`rotateL` 1)
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RRCA -> let _fCarry = (cpu ^. a) `testBit` 1 in
cpu & a %~ (`rotateR` 1)
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
pure $
cpu & a %~ (`rotateR` 1)
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RLA -> let _fCarry = (cpu ^. a) `testBit` 8
_c = cpu ^. carry in
cpu & a %~ (if _c then (+1) else id) . (.<<. 1)
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
pure $
cpu & a %~ (if _c then (+1) else id) . (.<<. 1)
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
RRA -> let _fCarry = (cpu ^. a) `testBit` 1
_c = cpu ^. carry in
cpu & a %~ (if _c then (+128) else id) . (.>>. 1)
& flags .~ FlagRegister {_fZero = False, _fNegative = False, _fHalfCarry = False, ..}
pure $
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
newValue = cpu ^. t `rotateL` 1 in
cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
pure $
cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RLCHL -> let target = cpu ^. hl
value = fetch cpu target
_fCarry = (value) `testBit` 8
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
newValue = cpu ^. t `rotateR` 1 in
cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
pure $
cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RRCHL -> let target = cpu ^. hl
value = fetch cpu target
_fCarry = value `testBit` 1
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
_c = cpu ^. carry
newValue = (if _c then (+1) else id) $ cpu ^. t .<<. 1 in
cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
pure $
cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RLHL -> let target = cpu ^. hl
value = fetch cpu target
_c = cpu ^. carry
_fCarry = value `testBit` 8
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
_c = cpu ^. carry
newValue = (if _c then (+128) else id) $ cpu ^. t .>>. 1 in
cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
pure $
cpu & t .~ newValue
& flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
RRHL -> let target = cpu ^. hl
value = fetch cpu target
_c = cpu ^. carry
_fCarry = value `testBit` 1
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
newValue = cpu ^. t .<<. 1
in
pure $
cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SLAHL -> let target = cpu ^. hl
value = fetch cpu target
newValue = value .<<. 1
_fCarry = value `testBit` 8
in
pure $
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SR t arith -> let _fCarry = (cpu ^. t) `testBit` 1
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
pure $
cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = 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
_fCarry = value `testBit` 1 in
pure $
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, ..}
SWAP t -> let newValue = cpu ^. t `rotateR` 4 in
pure $
cpu & t .~ newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, _fCarry = False}
SWAPHL -> let target = cpu ^. hl
value = fetch cpu target
newValue = value `rotateR` 4 in
pure $
write cpu target newValue & flags .~ FlagRegister {_fZero = newValue == 0, _fNegative = False, _fHalfCarry = False, _fCarry = False}
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
value = fetch cpu target in
cpu & flags %~ (\_f -> _f { _fZero = not $ value `testBit` i, _fNegative = False, _fHalfCarry = True })
RES t i -> cpu & t %~ (`clearBit` i)
pure $
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
value = fetch cpu target
newValue = value `clearBit` i in
pure $
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
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
pure $ write cpu target newValue
LDRR t _f -> pure $ cpu & t .~ cpu ^. _f
LDRN t v -> pure $ cpu & t .~ v
LDRHL t -> let target = cpu ^. hl
value = fetch cpu target in
cpu & t .~ value
pure $ cpu & t .~ value
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
write cpu target v
LDANN _f -> cpu & a .~ fetch cpu _f
LDNNA _t -> write cpu _t $ cpu ^. a
pure $ write cpu target v
LDANN _f -> pure $ cpu & a .~ fetch cpu _f
LDNNA _t -> pure $ write cpu _t $ cpu ^. a
LDHAC -> let target = 65280 + (fromIntegral $ cpu ^. c)
value = fetch cpu target in
cpu & a .~ value
pure $ cpu & a .~ value
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)
value = fetch cpu target in
cpu & a .~ value
pure $ cpu & a .~ value
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
value = fetch cpu target in
cpu & a .~ value
& hl %~ op
pure $
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 ^. hl
pure $
write cpu target (cpu ^. a)
& hl %~ op
LDRRNN t v -> pure $ cpu & t .~ v
LDNNSP v -> pure $ write cpu v . fetch cpu $ cpu ^. sp
LDSPHL -> pure $ cpu & sp .~ cpu ^. hl
PUSHRR t -> let cpu' = cpu & sp %~ subtract 1
(msb, lsb) = splitWord $ cpu ^. t
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)
cpu' = cpu & sp %~ (+1)
msb = fetch cpu' (cpu' ^. sp)
value = combineWords msb lsb
in
cpu & t .~ value
& sp %~ (+1)
pure $
cpu & t .~ value
& sp %~ (+1)
LDHLSPE v -> let value = cpu ^. sp
newValue :: Word16 = fromIntegral $ (fromIntegral value :: Integer) + (fromIntegral v) in
pure $
cpu & hl .~ value
& flags .~
FlagRegister { _fZero = False,
@@ -445,39 +525,60 @@ execute cpu = \case
_fHalfCarry = value .&. 16 + fromIntegral v .&. 16 > 16, -- TODO: check if this still works out
_fCarry = value > newValue
}
JPNN v -> cpu & pc .~ v
JPHL -> cpu & pc .~ cpu ^. hl
JPCCNN v _f op -> 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
JRCCE v _f op -> if op $ cpu ^. _f then
JPNN v -> pure $ cpu & pc .~ v
JPHL -> pure $ cpu & pc .~ cpu ^. hl
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 pure $ cpu & pc .~ target
JRCCE v _f op -> pure $ if op $ cpu ^. _f then
let target = fromIntegral $ (fromIntegral (cpu ^. pc) :: Integer) + fromIntegral v in
cpu & pc .~ target
else
cpu
CALLNN v -> undefined
CALLCCNN v _f op -> undefined
CALLNN v -> 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
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)
cpu' = cpu & sp %~ (+1)
msb = fetch cpu' (cpu' ^. sp)
value = combineWords msb lsb in
cpu & pc .~ value
& ie .~ 1
RETCC _f op -> undefined
pure $ cpu' & pc .~ value
& ie .~ 1
& 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)
cpu' = cpu & sp %~ (+1)
msb = fetch cpu' (cpu' ^. sp)
value = combineWords msb lsb in
pure $
cpu & pc .~ value
& ie .~ 1
RSTN v -> let cpu' = cpu & sp %~ subtract 1
(msb,lsb) = splitWord $ cpu ^. pc
cpu'' = write cpu' (cpu' ^. sp) msb & sp %~ subtract 1 in
write cpu'' (cpu'' ^. sp) lsb & pc .~ v
HALT -> undefined
pure $ write cpu'' (cpu'' ^. sp) lsb & pc .~ v
HALT -> Await Halted pure
STOP -> undefined
DI -> cpu & ie .~ 0
EI -> cpu & ie .~ 1
NOP -> cpu
DI -> pure $ cpu & ie .~ 0
EI -> pure $ cpu & ie .~ 1
NOP -> pure $ cpu
where
add :: Word8 -> Word8 -> Bool -> (Word8, FlagRegister)
add o n _c = let new = o + n + if _c then 1 else 0