fig-emulator-gb: Profiling the PPU

3 files changed, 107 insertions, 42 deletions

diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
index 1c64dfd..f0c461f 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
@@ -22,14 +22,14 @@ instance Pretty Addr where
 data Component = forall (s :: Type). Component
   { compState :: s
   , compMatches :: Addr -> Bool
-  , compUpdate :: s -> Int -> IO s
+  , compUpdate :: s -> Word16 -> IO s
   , compWrite :: s -> Addr -> Word8 -> IO s
   , compRead :: s -> Addr -> IO Word8
   }
 
 newtype Bus = Bus { busComponents :: [Component] }
 
-update :: Int -> Bus -> IO Bus
+update :: Word16 -> Bus -> IO Bus
 update t b = Bus <$> forM (busComponents b) \Component{..} -> do
   s <- compUpdate compState t
   pure Component { compState = s, ..}
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
index 9a6f557..651b27b 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
@@ -101,7 +101,8 @@ newtype Emulating a = Emulating { runEmulating :: StateT CPU IO a }
 --     rreg8 = pack . Pr.printf "%02X"
 --     rreg16 = pack . Pr.printf "%04X"
 
-updateComps :: Int -> Emulating ()
+-- | Inform all components that the given number of t-cycles have passed
+updateComps :: Word16 -> Emulating ()
 updateComps t = do
   b <- use bus
   b' <- liftIO $ Bus.update t b
@@ -109,12 +110,11 @@ updateComps t = do
 
 decode :: Emulating Instruction
 decode = do
-  -- updateComps 4
   b <- use bus
   pc <- use $ regs . regPC
   lastPC .= pc
   (ins, Addr a) <- liftIO $ readInstruction b $ Addr pc
-  -- lastIns .= ins
+  lastIns .= ins
   regs . regPC .= a
   pure ins
 
@@ -126,7 +126,6 @@ cond CondC = use (regs . regFlagC)
 
 read8 :: Addr -> Emulating Word8
 read8 a = do
-  -- updateComps 4
   b <- use bus
   pc <- use lastPC
   ins <- use lastIns
@@ -150,7 +149,6 @@ read16 a = do
 
 write8 :: Addr -> Word8 -> Emulating ()
 write8 a v = do
-  -- updateComps 4
   b <- use bus
   b' <- liftIO $ Bus.write b a v
   bus .= b'
@@ -679,6 +677,7 @@ step ins = do
     CbSetB3R8 (B3 idx) r -> {-# SCC "CbSetB3R8" #-} do
       v <- r8 r
       setR8 r $ v .|. shiftL 0b1 idx
+  updateComps 4
   where
     unimplemented :: Emulating ()
     unimplemented = do
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 2337a1c..7ddf8f5 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
@@ -133,52 +133,118 @@ compVideo framebuffer = Component
     , vstTick = 0
     }
   , compMatches = isJust  . videoAddrRange
-  , compUpdate = \olds t -> {-# SCC "ComponentVideoUpdate" #-} do
-      let tick = vstTick olds + fromIntegral t
-      let s = olds { vstTick = tick }
+  , compUpdate = \s t -> {-# SCC "ComponentVideoUpdate" #-} do
+      let tick = vstTick s + t
+      -- let ly = vstLy s + 1
+      let ly = 0
       case vstRenderState s of
         RenderOAMSearch
           | tick == 40 -> pure s
-            { vstRenderState = RenderPixelTransfer
+            { vstTick = tick
+            , vstRenderState = RenderPixelTransfer
             }
           | otherwise -> pure s
+            { vstTick = tick
+            }
         RenderPixelTransfer
           | tick == 200 -> pure s
-            { vstRenderState = RenderHBlank
+            { vstTick = tick
+            , vstRenderState = RenderHBlank
             }
           | otherwise -> pure s
+            { vstTick = tick
+            }
         RenderHBlank
           | tick == 456 -> do
-              let ly = vstLy olds + 1
-              if ly == 144
-                then
-                pure s { vstTick = 0, vstLy = ly, vstRenderState = RenderVBlank }
-                else
-                pure s { vstTick = 0, vstLy = ly, vstRenderState = RenderOAMSearch }
-          | otherwise -> pure s
-        RenderVBlank
-          | tick == 456 -> do
-              let ly = vstLy olds + 1
-              if ly == 153
-                then do
-                -- 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_ ([0..10] :: [Int]) \x -> do
-                --   forM_ ([0..10] :: [Int]) \y -> do
-                --     let i = y * 10 + x
-                --     blitTile (vstVRAM s)
-                --       (0x200 + fromIntegral i * 16)
-                --       (fromIntegral $ x * 8, fromIntegral $ y * 8)
-                --       $ vstFb s
-                pure s { vstTick = 0, vstLy = 0, vstRenderState = RenderOAMSearch }
-                else
-                pure s { vstTick = 0, vstLy = ly }
-          | otherwise -> pure s
+              pure s
+                { vstTick = 0
+                , vstLy = ly
+                , vstRenderState = RenderOAMSearch
+                }
+              -- let ly = vstLy s + 1
+              -- if ly == 144
+              --   then
+              --   pure s
+              --   { vstTick = 0
+              --   , vstLy = ly
+              --   -- , vstRenderState = RenderVBlank
+              --   , vstRenderState = RenderOAMSearch
+              --   }
+              --   else
+              --   pure s
+              --   { vstTick = 0
+              --   , vstLy = ly
+              --   , vstRenderState = RenderOAMSearch
+              --   }
+        _ -> pure s { vstTick = tick }
+      -- case vstRenderState s of
+      --   RenderOAMSearch
+      --     | tick == 40 -> pure $! s
+      --       { vstTick = tick
+      --       , vstRenderState = RenderPixelTransfer
+      --       }
+      --     | otherwise -> pure $! s
+      --       { vstTick = tick
+      --       }
+      --   RenderPixelTransfer
+      --     | tick == 200 -> pure $! s
+      --       { vstTick = tick
+      --       , vstRenderState = RenderHBlank
+      --       }
+      --     | otherwise -> pure $! s
+      --       { vstTick = tick
+      --       }
+      --   RenderHBlank
+      --     | tick == 456 -> do
+      --         let ly = vstLy s + 1
+      --         if ly == 144
+      --           then
+      --           pure $! s
+      --           { vstTick = 0
+      --           , vstLy = ly
+      --           , vstRenderState = RenderVBlank
+      --           }
+      --           else
+      --           pure $! s
+      --           { vstTick = 0
+      --           , vstLy = ly
+      --           , vstRenderState = RenderOAMSearch
+      --           }
+      --     | otherwise -> pure $! s
+      --       { vstTick = tick
+      --       }
+      --   RenderVBlank
+      --     | tick == 456 -> do
+      --         let ly = vstLy s + 1
+      --         if ly == 153
+      --           then do
+      --           -- 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_ ([0..10] :: [Int]) \x -> do
+      --           --   forM_ ([0..10] :: [Int]) \y -> do
+      --           --     let i = y * 10 + x
+      --           --     blitTile (vstVRAM s)
+      --           --       (0x200 + fromIntegral i * 16)
+      --           --       (fromIntegral $ x * 8, fromIntegral $ y * 8)
+      --           --       $ vstFb s
+      --           pure $! s
+      --             { vstTick = 0
+      --             , vstLy = 0
+      --             , vstRenderState = RenderOAMSearch
+      --             }
+      --           else
+      --           pure $! s
+      --           { vstTick = 0
+      --           , vstLy = ly
+      --           }
+      --     | otherwise -> pure $! s
+      --       { vstTick = tick
+      --       }
   , compWrite = \s a v -> {-# SCC "ComponentVideoWrite" #-} case videoAddrRange a of
       Nothing -> throwM $ VideoError $ mconcat
         [ "write address out of bounds for video system: "