fig-emulator-gb: Fix space leak

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