diff options
Diffstat (limited to 'fig-emulator-gb/src/Fig/Emulator/GB/Component')
4 files changed, 64 insertions, 31 deletions
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs new file mode 100644 index 0000000..ec5540c --- /dev/null +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs @@ -0,0 +1,33 @@ +module Fig.Emulator.GB.Component.Interrupt where + +import Fig.Prelude + +import Fig.Emulator.GB.Utils +import Fig.Emulator.GB.Bus + +newtype InterruptError = InterruptError Text + deriving Show +instance Exception InterruptError +instance Pretty InterruptError where + pretty (InterruptError b) = mconcat + [ "interrupt error: " + , b + ] + +compInterrupt :: (MonadIO m, MonadThrow m) => Component m +compInterrupt = Component + { compState = () + , compMatches = \a -> a == 0xff0f || a == 0xffff + , compUpdate = \s _ -> pure s + , compWrite = \s (Addr a) v -> do + case a of + 0xff0f -> do + -- log $ "set IF:" <> show8 v + pure () + 0xffff -> do + -- log $ "set IE:" <> show8 v + pure () + _ -> throwM . InterruptError $ "write to invalid address: " <> pretty (Addr a) + pure s + , compRead = \_ _ -> pure 0x00 + } diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs index e20dd8d..b17292c 100644 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs @@ -3,7 +3,6 @@ module Fig.Emulator.GB.Component.RAM ) where import Fig.Prelude -import Prelude (fromIntegral) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV @@ -25,11 +24,11 @@ compWRAM start size = Component { compState = V.replicate size 0 :: V.Vector Word8 , compMatches = \a -> a >= start && a <= end - , compUpdate = \s _ -> pure s - , compWrite = \s ad v -> do + , compUpdate = \s _ -> {-# SCC "ComponentWRAMUpdate" #-} pure s + , compWrite = \s ad v -> {-# SCC "ComponentWRAMWrite" #-} do let offset = fromIntegral . unAddr $ ad - start pure $ V.modify (\ms -> MV.write ms offset v) s - , compRead = \s ad -> do + , compRead = \s ad -> {-# SCC "ComponentWRAMRead" #-} do let offset = fromIntegral . unAddr $ ad - start case s V.!? offset of Nothing -> throwM . RAMError $ mconcat diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs index 59200f1..0ee529b 100644 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs @@ -18,16 +18,18 @@ instance Pretty SerialError where , b ] -compSerial :: (MonadIO m, MonadThrow m) => Handle -> Component m -compSerial h = Component +compSerial :: (MonadIO m, MonadThrow m) => Maybe Handle -> Component m +compSerial mh = Component { compState = () , compMatches = (== 0xff01) , compUpdate = \s _ -> pure s , compWrite = \s _ v -> do - log $ mconcat - [ "wrote serial byte: ", tshow $ chr $ fromIntegral v - ] - liftIO . hPutChar h . chr $ fromIntegral v + -- log $ mconcat + -- [ "wrote serial byte: ", tshow $ chr $ fromIntegral v + -- ] + case mh of + Nothing -> pure () + Just h -> liftIO . hPutChar h . chr $ fromIntegral v pure s , compRead = \_ _ -> pure 0x00 } diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs index 3f73be0..9326e41 100644 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs @@ -1,7 +1,7 @@ module Fig.Emulator.GB.Component.Video where import Fig.Prelude -import Prelude (error, fromIntegral) +import Prelude (error) import qualified Foreign.Ptr as Ptr import qualified Foreign.Storable as St @@ -16,7 +16,6 @@ import qualified SDL import Fig.Emulator.GB.Utils import Fig.Emulator.GB.Bus -import Data.Vector.Generic.Lens (vector) newtype VideoError = VideoError Text deriving Show @@ -93,8 +92,8 @@ blitTile v (Addr a) (bx, by) fb = do (x, y) fb data VideoAddrRange - = VideoAddrVRAM !Addr - | VideoAddrStatus !Addr + = VideoAddrVRAM Addr + | VideoAddrStatus Addr deriving Show videoAddrRange :: Addr -> Maybe VideoAddrRange @@ -111,14 +110,14 @@ data RenderState deriving Show data VideoState = VideoState - { vstFb :: !Framebuffer - , vstVRAM :: !(V.Vector Word8) - , vstScx :: !Word8 - , vstScy :: !Word8 - , vstLy :: !Word8 - , vstLx :: !Word8 - , vstRenderState :: !RenderState - , vstTick :: !Word16 + { vstFb :: Framebuffer + , vstVRAM :: V.Vector Word8 + , vstScx :: Word8 + , vstScy :: Word8 + , vstLy :: Word8 + , vstLx :: Word8 + , vstRenderState :: RenderState + , vstTick :: Word16 } compVideo :: (MonadIO m, MonadThrow m) => Framebuffer -> Component m @@ -134,7 +133,7 @@ compVideo framebuffer = Component , vstTick = 0 } , compMatches = isJust . videoAddrRange - , compUpdate = \olds t -> do + , compUpdate = \olds t -> {-# SCC "ComponentVideoUpdate" #-} do let tick = vstTick olds + fromIntegral t let s = olds { vstTick = tick } case vstRenderState s of @@ -162,13 +161,13 @@ compVideo framebuffer = Component let ly = vstLy olds + 1 if ly == 153 then do - log "vblank" + -- log "vblank" -- logTilemap $ vstVRAM s - forM_ (zip [0..] [48,52,45,111,112,32,114,44,105,109,109] :: [(Int, Int)]) \(idx, b) -> do - blitTile (vstVRAM s) - (fromIntegral $ b * 16) - (fromIntegral $ idx * 8, 0) - $ vstFb s + -- forM_ (zip [0..] [48,52,45,111,112,32,114,44,105,109,109] :: [(Int, Int)]) \(idx, b) -> do + -- blitTile (vstVRAM s) + -- (fromIntegral $ b * 16) + -- (fromIntegral $ idx * 8, 0) + -- $ vstFb s -- forM_ ([0..10] :: [Int]) \x -> do -- forM_ ([0..10] :: [Int]) \y -> do -- let i = y * 10 + x @@ -180,7 +179,7 @@ compVideo framebuffer = Component else pure s { vstTick = 0, vstLy = ly } | otherwise -> pure s - , compWrite = \s a v -> case videoAddrRange a of + , compWrite = \s a v -> {-# SCC "ComponentVideoWrite" #-} case videoAddrRange a of Nothing -> throwM $ VideoError $ mconcat [ "write address out of bounds for video system: " , pretty a @@ -205,7 +204,7 @@ compVideo framebuffer = Component 0xa -> pure s 0xb -> pure s _ -> pure s - , compRead = \s a -> case videoAddrRange a of + , compRead = \s a -> {-# SCC "ComponentVideoRead" #-} case videoAddrRange a of Nothing -> throwM $ VideoError $ mconcat [ "read address out of bounds for video system: " , pretty a |