From a81c92dc2cdff02c55fdc197d943bc7a35c64be5 Mon Sep 17 00:00:00 2001
From: LLLL Colonq <llll@colonq>
Date: Tue, 7 May 2024 14:21:13 -0400
Subject: fig-emulator-gb: Fix space leak

---
 fig-emulator-gb/src/Fig/Emulator/GB.hs             |  57 ++++----
 fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs         |  10 +-
 fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs         | 162 ++++++++++-----------
 .../src/Fig/Emulator/GB/Component/Interrupt.hs     |  33 +++++
 .../src/Fig/Emulator/GB/Component/RAM.hs           |   7 +-
 .../src/Fig/Emulator/GB/Component/Serial.hs        |  14 +-
 .../src/Fig/Emulator/GB/Component/Video.hs         |  41 +++---
 fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs  |   2 +-
 8 files changed, 183 insertions(+), 143 deletions(-)
 create mode 100644 fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs

(limited to 'fig-emulator-gb/src')

diff --git a/fig-emulator-gb/src/Fig/Emulator/GB.hs b/fig-emulator-gb/src/Fig/Emulator/GB.hs
index 76e6c85..6f32682 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB.hs
@@ -6,7 +6,7 @@ import System.IO (withFile, IOMode (WriteMode))
 
 import Control.Lens ((.=), use)
 import Control.Monad (when)
-import Control.Monad.State (StateT(..))
+import Control.Monad.State.Strict (StateT(..))
 
 import qualified SDL
 
@@ -18,9 +18,10 @@ import Fig.Emulator.GB.Component.ROM
 import Fig.Emulator.GB.Component.Video
 import Fig.Emulator.GB.Component.Joystick
 import Fig.Emulator.GB.Component.Serial
+import Fig.Emulator.GB.Component.Interrupt (compInterrupt)
 
-cpuDMG :: (MonadIO m, MonadThrow m) => Handle -> ByteString -> Framebuffer -> CPU m
-cpuDMG h rom fb = CPU
+cpuDMG :: (MonadIO m, MonadThrow m) => Maybe Handle -> ByteString -> Framebuffer -> CPU m
+cpuDMG serial rom fb = CPU
   { _lastPC = 0x0
   , _lastIns = Nop
   , _running = True
@@ -30,26 +31,30 @@ cpuDMG h rom fb = CPU
     , compWRAM 0xc000 $ 8 * 1024
     , compVideo fb
     , compJoystick
-    , compSerial h
+    , compSerial serial
+    , compInterrupt
     , compWRAM 0xff80 0x7e -- HRAM
     ]
   }
 
-testRun :: forall m. (MonadIO m, MonadThrow m) => FilePath -> ByteString -> m ()
+testRun :: forall m. (MonadIO m, MonadThrow m) => Maybe FilePath -> ByteString -> m ()
 testRun serialOut rom = do
   SDL.initializeAll
   window <- SDL.createWindow "taking" SDL.defaultWindow
   fb <- initializeFramebuffer
-  liftIO $ withFile serialOut WriteMode \hserial -> do
+  let withSerial f = case serialOut of
+        Nothing -> f Nothing
+        Just p -> withFile p WriteMode $ f . Just
+  liftIO $ withSerial \hserial -> do
     let cpu = cpuDMG hserial rom fb
     let
       loop :: forall m'. Emulating m' => Int -> m' ()
       loop cycle = do
-        events <- SDL.pollEvents
-        forM_ events \ev ->
-          case SDL.eventPayload ev of
-            SDL.QuitEvent -> running .= False
-            _else -> pure ()
+        -- events <- SDL.pollEvents
+        -- forM_ events \ev ->
+        --   case SDL.eventPayload ev of
+        --     SDL.QuitEvent -> running .= False
+        --     _else -> pure ()
         pc <- use $ regs . regPC
         ins <- decode
         when (pc == 0x2817) do
@@ -58,20 +63,22 @@ testRun serialOut rom = do
             , ": ", tshow ins
             ]
         step ins
-        when (rem cycle 70224 == 0) do
-          ws <- SDL.getWindowSurface window
-          SDL.surfaceFillRect ws Nothing $ SDL.V4 0x00 0x00 0x00 0xff
-          void $
-            SDL.surfaceBlitScaled
-            (fbSurface fb)
-            Nothing
-            ws
-            (Just $ SDL.Rectangle
-             (SDL.P $ SDL.V2 0 0)
-             (SDL.V2
-              (fromIntegral screenWidth * 8)
-              (fromIntegral screenHeight * 8)))
-          SDL.updateWindowSurface window
+        when (rem cycle 1000000 == 0) do
+          log "1 million"
+        -- when (rem cycle 70224 == 0) do
+        --   ws <- SDL.getWindowSurface window
+        --   SDL.surfaceFillRect ws Nothing $ SDL.V4 0x00 0x00 0x00 0xff
+        --   void $
+        --     SDL.surfaceBlitScaled
+        --     (fbSurface fb)
+        --     Nothing
+        --     ws
+        --     (Just $ SDL.Rectangle
+        --      (SDL.P $ SDL.V2 0 0)
+        --      (SDL.V2
+        --       (fromIntegral screenWidth * 8)
+        --       (fromIntegral screenHeight * 8)))
+        --   SDL.updateWindowSurface window
         r <- use running
         when r . loop $ cycle + 1
     void $ flip runStateT cpu do
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
index dd61dbc..6550d2d 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
@@ -20,11 +20,11 @@ instance Pretty Addr where
   pretty (Addr w) = "$" <> pack (showHex w "")
 
 data Component m = forall (s :: Type). Component
-  { compState :: !s
-  , compMatches :: !(Addr -> Bool)
-  , compUpdate :: !(s -> Int -> m s)
-  , compWrite :: !(s -> Addr -> Word8 -> m s)
-  , compRead :: !(s -> Addr -> m Word8)
+  { compState :: s
+  , compMatches :: Addr -> Bool
+  , compUpdate :: s -> Int -> m s
+  , compWrite :: s -> Addr -> Word8 -> m s
+  , compRead :: s -> Addr -> m Word8
   }
 
 newtype Bus m = Bus { busComponents :: [Component m] }
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
index cd4abba..6f56324 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
@@ -63,11 +63,11 @@ initialRegs = Registers
   }
 
 data CPU m = CPU
-  { _lastPC :: !Word16
-  , _lastIns :: !Instruction
-  , _running :: !Bool
-  , _regs :: !Registers
-  , _bus :: !(Bus m)
+  { _lastPC :: Word16
+  , _lastIns :: Instruction
+  , _running :: Bool
+  , _regs :: Registers
+  , _bus :: Bus m
   }
 makeLenses 'CPU
 
@@ -108,7 +108,7 @@ updateComps t = do
 
 decode :: Emulating m => m Instruction
 decode = do
-  updateComps 4
+  -- updateComps 4
   b <- use bus
   pc <- use $ regs . regPC
   lastPC .= pc
@@ -125,7 +125,7 @@ cond CondC = use (regs . regFlagC)
 
 read8 :: Emulating m => Addr -> m Word8
 read8 a = do
-  updateComps 4
+  -- updateComps 4
   b <- use bus
   pc <- use lastPC
   ins <- use lastIns
@@ -149,7 +149,7 @@ read16 a = do
 
 write8 :: Emulating m => Addr -> Word8 -> m ()
 write8 a v = do
-  updateComps 4
+  -- updateComps 4
   b <- use bus
   b' <- liftIO $ Bus.write b a v
   bus .= b'
@@ -257,27 +257,27 @@ step ins = do
       regs . regFlagN .= False
       pure res
   case ins of
-    Nop -> pure ()
-    LdR16Imm16 r (Imm16 i) -> setR16 r i
-    LdR16MemA r -> do
+    Nop -> {-# SCC "Nop" #-} pure ()
+    LdR16Imm16 r (Imm16 i) -> {-# SCC "LdR16Imm16" #-} setR16 r i
+    LdR16MemA r -> {-# SCC "LdR16MemA" #-} do
       addr <- r16Mem r
       a <- r8 R8A
       write8 (Addr addr) a
-    LdAR16Mem r -> do
+    LdAR16Mem r -> {-# SCC "LdAR16Mem" #-} do
       addr <- r16Mem r
       v <- read8 $ Addr addr
       setR8 R8A v
-    LdImm16Sp (Imm16 addr) -> do
+    LdImm16Sp (Imm16 addr) -> {-# SCC "LdImm16Sp" #-} do
       sp <- r16 R16SP
       write8 (Addr addr) $ w16lo sp
       write8 (Addr addr + 1) $ w16hi sp
-    IncR16 r -> do
+    IncR16 r -> {-# SCC "IncR16" #-} do
       v <- r16 r
       setR16 r $ v + 1
-    DecR16 r -> do
+    DecR16 r -> {-# SCC "DecR16" #-} do
       v <- r16 r
       setR16 r $ v - 1
-    AddHlR16 r -> do
+    AddHlR16 r -> {-# SCC "AddHlR16" #-} do
       x <- r16 R16HL
       y <- r16 r
       let
@@ -289,14 +289,14 @@ step ins = do
       regs . regFlagC .= (shiftR resl 16 .&. 0b1 == 0b1)
       regs . regFlagN .= False
       setR16 R16HL res
-    IncR8 r -> do
+    IncR8 r -> {-# SCC "IncR8" #-} do
       v <- r8 r
       let (res, _) = addC False v 1
       regs . regFlagH .= addH False v 1
       regs . regFlagZ .= (res == 0)
       regs . regFlagN .= False
       setR8 r res
-    DecR8 r -> do
+    DecR8 r -> {-# SCC "DecR8" #-} do
       v <- r8 r
       let
         res :: Word8
@@ -305,22 +305,22 @@ step ins = do
       regs . regFlagZ .= (res == 0)
       regs . regFlagN .= True
       setR8 r res
-    LdR8Imm8 r (Imm8 i) -> setR8 r i
-    Rlca -> do
+    LdR8Imm8 r (Imm8 i) -> {-# SCC "LdR8Imm8" #-} setR8 r i
+    Rlca -> {-# SCC "Rlca" #-} do
       v <- r8 R8A
       regs . regFlagH .= False
       regs . regFlagZ .= False
       regs . regFlagN .= False
       regs . regFlagC .= w8bit 7 v
       setR8 R8A $ rotateL v 1
-    Rrca -> do
+    Rrca -> {-# SCC "Rrca" #-} do
       v <- r8 R8A
       regs . regFlagH .= False
       regs . regFlagZ .= False
       regs . regFlagN .= False
       regs . regFlagC .= w8bit 0 v
       setR8 R8A $ rotateR v 1
-    Rla -> do
+    Rla -> {-# SCC "Rla" #-} do
       v <- r8 R8A
       c <- use $ regs . regFlagC
       regs . regFlagH .= False
@@ -328,7 +328,7 @@ step ins = do
       regs . regFlagN .= False
       regs . regFlagC .= w8bit 7 v
       setR8 R8A $ shiftL v 1 .|. if c then 1 else 0
-    Rra -> do
+    Rra -> {-# SCC "Rra" #-} do
       v <- r8 R8A
       c <- use $ regs . regFlagC
       regs . regFlagH .= False
@@ -336,7 +336,7 @@ step ins = do
       regs . regFlagN .= False
       regs . regFlagC .= w8bit 0 v
       setR8 R8A $ shiftR v 1 .|. if c then 0b10000000 else 0
-    Daa -> do
+    Daa -> {-# SCC "Daa" #-} do
       v <- r8 R8A
       halfcarry <- use $ regs . regFlagH
       carry <- use $ regs . regFlagC
@@ -353,34 +353,34 @@ step ins = do
       regs . regFlagZ .= (res == 0)
       regs . regFlagC .= c
       pure ()
-    Cpl -> do
+    Cpl -> {-# SCC "Cpl" #-} do
       v <- r8 R8A
       regs . regFlagH .= True
       regs . regFlagN .= True
       setR8 R8A $ complement v
-    Scf -> do
+    Scf -> {-# SCC "Scf" #-} do
       regs . regFlagH .= False
       regs . regFlagN .= False
       regs . regFlagC .= True
-    Ccf -> do
+    Ccf -> {-# SCC "Ccf" #-} do
       c <- use $ regs . regFlagC
       regs . regFlagH .= False
       regs . regFlagN .= False
       regs . regFlagC .= not c
-    JrImm8 (Imm8 i) -> do
+    JrImm8 (Imm8 i) -> {-# SCC "JrImm8" #-} do
       pc <- use $ regs . regPC
       regs . regPC .= pc + sext i
-    JrCondImm8 c (Imm8 i) -> do
+    JrCondImm8 c (Imm8 i) -> {-# SCC "JrCondImm8" #-} do
       b <- cond c
       when b do
         pc <- use $ regs . regPC
         regs . regPC .= pc + sext i
-    Stop -> unimplemented
-    LdR8R8 dst src -> do
+    Stop -> {-# SCC "Stop" #-} unimplemented
+    LdR8R8 dst src -> {-# SCC "LdR8R8" #-} do
       v <- r8 src
       setR8 dst v
-    Halt -> unimplemented
-    AddAR8 i -> do
+    Halt -> {-# SCC "Halt" #-} unimplemented
+    AddAR8 i -> {-# SCC "AddAR8" #-} do
       x <- r8 R8A
       y <- r8 i
       let (res, carry) = addC False x y
@@ -389,7 +389,7 @@ step ins = do
       regs . regFlagZ .= (res .&. 0xff == 0)
       regs . regFlagN .= False
       regs . regA .= res
-    AdcAR8 i -> do
+    AdcAR8 i -> {-# SCC "AdcAR8" #-} do
       x <- r8 R8A
       y <- r8 i
       c <- use $ regs . regFlagC
@@ -399,7 +399,7 @@ step ins = do
       regs . regFlagZ .= (res .&. 0xff == 0)
       regs . regFlagN .= False
       regs . regA .= res
-    SubAR8 i -> do
+    SubAR8 i -> {-# SCC "SubAR8" #-} do
       x <- r8 R8A
       y <- r8 i
       let (res, carry) = subC False x y
@@ -408,7 +408,7 @@ step ins = do
       regs . regFlagZ .= (res .&. 0xff == 0)
       regs . regFlagN .= True
       regs . regA .= res
-    SbcAR8 i -> do
+    SbcAR8 i -> {-# SCC "SbcAR8" #-} do
       x <- r8 R8A
       y <- r8 i
       c <- use $ regs . regFlagC
@@ -418,23 +418,23 @@ step ins = do
       regs . regFlagZ .= (res .&. 0xff == 0)
       regs . regFlagN .= True
       regs . regA .= res
-    AndAR8 i -> do
+    AndAR8 i -> {-# SCC "AndAR8" #-} do
       x <- r8 R8A
       y <- r8 i
       res <- bitwise8 (.&.) x y
       regs . regFlagH .= True
       regs . regA .= res
-    XorAR8 i -> do
+    XorAR8 i -> {-# SCC "XorAR8" #-} do
       x <- r8 R8A
       y <- r8 i
       res <- bitwise8 xor x y
       regs . regA .= res
-    OrAR8 i -> do
+    OrAR8 i -> {-# SCC "OrAR8" #-} do
       x <- r8 R8A
       y <- r8 i
       res <- bitwise8 (.|.) x y
       regs . regA .= res
-    CpAR8 i -> do
+    CpAR8 i -> {-# SCC "CpAR8" #-} do
       x <- r8 R8A
       y <- r8 i
       let (res, carry) = subC False x y
@@ -442,7 +442,7 @@ step ins = do
       regs . regFlagC .= carry
       regs . regFlagZ .= (res .&. 0xff == 0)
       regs . regFlagN .= True
-    AddAImm8 (Imm8 y) -> do
+    AddAImm8 (Imm8 y) -> {-# SCC "AddAImm8" #-} do
       x <- r8 R8A
       let (res, carry) = addC False x y
       regs . regFlagH .= addH False x y
@@ -450,7 +450,7 @@ step ins = do
       regs . regFlagZ .= (res .&. 0xff == 0)
       regs . regFlagN .= False
       regs . regA .= res
-    AdcAImm8 (Imm8 y) -> do
+    AdcAImm8 (Imm8 y) -> {-# SCC "AdcAImm8" #-} do
       x <- r8 R8A
       c <- use $ regs . regFlagC
       let (res, carry) = addC c x y
@@ -459,7 +459,7 @@ step ins = do
       regs . regFlagZ .= (res .&. 0xff == 0)
       regs . regFlagN .= False
       regs . regA .= res
-    SubAImm8 (Imm8 y) -> do
+    SubAImm8 (Imm8 y) -> {-# SCC "SubAImm8" #-} do
       x <- r8 R8A
       let (res, carry) = subC False x y
       regs . regFlagH .= subH False x y
@@ -467,7 +467,7 @@ step ins = do
       regs . regFlagZ .= (res .&. 0xff == 0)
       regs . regFlagN .= True
       regs . regA .= res
-    SbcAImm8 (Imm8 y) -> do
+    SbcAImm8 (Imm8 y) -> {-# SCC "SbcAImm8" #-} do
       x <- r8 R8A
       c <- use $ regs . regFlagC
       let (res, carry) = subC c x y
@@ -476,50 +476,50 @@ step ins = do
       regs . regFlagZ .= (res .&. 0xff == 0)
       regs . regFlagN .= True
       regs . regA .= res
-    AndAImm8 (Imm8 y) -> do
+    AndAImm8 (Imm8 y) -> {-# SCC "AndAImm8" #-} do
       x <- r8 R8A
       res <- bitwise8 (.&.) x y
       regs . regFlagH .= True
       regs . regA .= res
-    XorAImm8 (Imm8 y) -> do
+    XorAImm8 (Imm8 y) -> {-# SCC "XorAImm8" #-} do
       x <- r8 R8A
       res <- bitwise8 xor x y
       regs . regA .= res
-    OrAImm8 (Imm8 y) -> do
+    OrAImm8 (Imm8 y) -> {-# SCC "OrAImm8" #-} do
       x <- r8 R8A
       res <- bitwise8 (.|.) x y
       regs . regA .= res
-    CpAImm8 (Imm8 y) -> do
+    CpAImm8 (Imm8 y) -> {-# SCC "CpAImm8" #-} do
       x <- r8 R8A
       void $ sub8 (-) x y
-    RetCond c -> do
+    RetCond c -> {-# SCC "RetCond" #-} do
       b <- cond c
       when b do
         sp <- r16 R16SP
         v <- read16 $ Addr sp
         setR16 R16SP $ sp + 2
         regs . regPC .= v
-    Ret -> do
+    Ret -> {-# SCC "Ret" #-} do
       sp <- r16 R16SP
       v <- read16 $ Addr sp
       setR16 R16SP $ sp + 2
       regs . regPC .= v
-    Reti -> do
+    Reti -> {-# SCC "Reti" #-} do
       regs . regFlagIME .= True
       sp <- r16 R16SP
       v <- read16 $ Addr sp
       setR16 R16SP $ sp + 2
       regs . regPC .= v
-    JpCondImm16 c (Imm16 i) -> do
+    JpCondImm16 c (Imm16 i) -> {-# SCC "JpCondImm16" #-} do
       b <- cond c
       when b do
         regs . regPC .= i
-    JpImm16 (Imm16 i) -> do
+    JpImm16 (Imm16 i) -> {-# SCC "JpImm16" #-} do
       regs . regPC .= i
-    JpHl -> do
+    JpHl -> {-# SCC "JpHl" #-} do
       hl <- r16 R16HL
       regs . regPC .= hl
-    CallCondImm16 c (Imm16 i) -> do
+    CallCondImm16 c (Imm16 i) -> {-# SCC "CallCondImm16" #-} do
       b <- cond c
       when b do
         next <- use $ regs . regPC
@@ -527,49 +527,49 @@ step ins = do
         setR16 R16SP sp
         write16 (Addr sp) next
         regs . regPC .= i
-    CallImm16 (Imm16 i) -> do
+    CallImm16 (Imm16 i) -> {-# SCC "CallImm16" #-} do
       next <- use $ regs . regPC
       sp <- (\x -> x - 2) <$> r16 R16SP
       setR16 R16SP sp
       write16 (Addr sp) next
       regs . regPC .= i
-    RstTgt3 (Tgt3 v) -> do
+    RstTgt3 (Tgt3 v) -> {-# SCC "RstTgt3" #-} do
       next <- use $ regs . regPC
       sp <- (\x -> x - 2) <$> r16 R16SP
       setR16 R16SP sp
       write16 (Addr sp) next
       regs . regPC .= shiftL (fromIntegral v) 3
-    PopR16Stk r -> do
+    PopR16Stk r -> {-# SCC "PopR16Stk" #-} do
       sp <- r16 R16SP
       v <- read16 $ Addr sp
       setR16 R16SP $ sp + 2
       setR16Stk r v
-    PushR16Stk r -> do
+    PushR16Stk r -> {-# SCC "PushR16Stk" #-} do
       sp <- (\x -> x - 2) <$> r16 R16SP
       v <- r16Stk r
       setR16 R16SP sp
       write16 (Addr sp) v
-    LdhCA -> do
+    LdhCA -> {-# SCC "LdhCA" #-} do
       c <- r8 R8C
       a <- r8 R8A
       write8 (Addr $ 0xff00 + zext c) a
-    LdhImm8A (Imm8 i) -> do
+    LdhImm8A (Imm8 i) -> {-# SCC "LdhImm8A" #-} do
       a <- r8 R8A
       write8 (Addr $ 0xff00 + zext i) a
-    LdImm16A (Imm16 i) -> do
+    LdImm16A (Imm16 i) -> {-# SCC "LdImm16A" #-} do
       a <- r8 R8A
       write8 (Addr i) a
-    LdhAC -> do
+    LdhAC -> {-# SCC "LdhAC" #-} do
       c <- r8 R8C
       v <- read8 (Addr $ 0xff00 + zext c)
       setR8 R8A v
-    LdhAImm8 (Imm8 i) -> do
+    LdhAImm8 (Imm8 i) -> {-# SCC "LdhAImm8" #-} do
       v <- read8 (Addr $ 0xff00 + zext i)
       setR8 R8A v
-    LdAImm16 (Imm16 i) -> do
+    LdAImm16 (Imm16 i) -> {-# SCC "LdAImm16" #-} do
       v <- read8 (Addr i)
       setR8 R8A v
-    AddSpImm8 (Imm8 y) -> do
+    AddSpImm8 (Imm8 y) -> {-# SCC "AddSpImm8" #-} do
       x <- r16 R16SP
       let
         res :: Word16
@@ -580,7 +580,7 @@ step ins = do
       regs . regFlagZ .= False
       regs . regFlagN .= False
       setR16 R16SP res
-    LdHlSpPlusImm8 (Imm8 y) -> do
+    LdHlSpPlusImm8 (Imm8 y) -> {-# SCC "LdHlSpPlusImm8" #-} do
       x <- r16 R16SP
       let
         res :: Word16
@@ -591,12 +591,12 @@ step ins = do
       regs . regFlagZ .= False
       regs . regFlagN .= False
       setR16 R16HL res
-    LdSpHl -> do
+    LdSpHl -> {-# SCC "LdSpHl" #-} do
       v <- r16 R16HL
       setR16 R16SP v
-    Di -> regs . regFlagIME .= False
-    Ei -> regs . regFlagIME .= True
-    CbRlcR8 r -> do
+    Di -> {-# SCC "Di" #-} regs . regFlagIME .= False
+    Ei -> {-# SCC "Ei" #-} regs . regFlagIME .= True
+    CbRlcR8 r -> {-# SCC "CbRlcR8" #-} do
       v <- r8 r
       let res = rotateL v 1
       regs . regFlagH .= False
@@ -604,7 +604,7 @@ step ins = do
       regs . regFlagN .= False
       regs . regFlagC .= w8bit 7 v
       setR8 r res
-    CbRrcR8 r -> do
+    CbRrcR8 r -> {-# SCC "CbRrcR8" #-} do
       v <- r8 r
       let res = rotateR v 1
       regs . regFlagH .= False
@@ -612,7 +612,7 @@ step ins = do
       regs . regFlagN .= False
       regs . regFlagC .= w8bit 0 v
       setR8 r res
-    CbRlR8 r -> do
+    CbRlR8 r -> {-# SCC "CbRlR8" #-} do
       v <- r8 r
       c <- use $ regs . regFlagC
       let res = shiftL v 1 .|. if c then 0b1 else 0
@@ -621,7 +621,7 @@ step ins = do
       regs . regFlagN .= False
       regs . regFlagC .= w8bit 7 v
       setR8 r res
-    CbRrR8 r -> do
+    CbRrR8 r -> {-# SCC "CbRrR8" #-} do
       v <- r8 r
       c <- use $ regs . regFlagC
       let rizz = shiftR v 1 .|. if c then 0b10000000 else 0
@@ -630,7 +630,7 @@ step ins = do
       regs . regFlagN .= False
       regs . regFlagC .= w8bit 0 v
       setR8 r rizz
-    CbSlaR8 r -> do
+    CbSlaR8 r -> {-# SCC "CbSlaR8" #-} do
       v <- r8 r
       let res = shiftL v 1
       regs . regFlagZ .= (res == 0)
@@ -638,7 +638,7 @@ step ins = do
       regs . regFlagN .= False
       regs . regFlagC .= w8bit 7 v
       setR8 r res
-    CbSraR8 r -> do
+    CbSraR8 r -> {-# SCC "CbSraR8" #-} do
       v <- r8 r
       let
         vs :: Int8
@@ -651,7 +651,7 @@ step ins = do
       regs . regFlagN .= False
       regs . regFlagC .= w8bit 0 v
       setR8 r res
-    CbSwapR8 r -> do
+    CbSwapR8 r -> {-# SCC "CbSwapR8" #-} do
       v <- r8 r
       let res = rotate v 4
       regs . regFlagZ .= (res == 0)
@@ -659,7 +659,7 @@ step ins = do
       regs . regFlagN .= False
       regs . regFlagC .= False
       setR8 r res
-    CbSrlR8 r -> do
+    CbSrlR8 r -> {-# SCC "CbSrlR8" #-} do
       v <- r8 r
       let res = shiftR v 1
       regs . regFlagZ .= (res == 0)
@@ -667,15 +667,15 @@ step ins = do
       regs . regFlagN .= False
       regs . regFlagC .= w8bit 0 v
       setR8 r res
-    CbBitB3R8 (B3 idx) r -> do
+    CbBitB3R8 (B3 idx) r -> {-# SCC "CbBitB3R8" #-} do
       v <- r8 r
       regs . regFlagH .= True
       regs . regFlagN .= False
       regs . regFlagZ .= not (w8bit idx v)
-    CbResB3R8 (B3 idx) r -> do
+    CbResB3R8 (B3 idx) r -> {-# SCC "CbResB3R8" #-} do
       v <- r8 r
       setR8 r $ v .&. (0xff .^. shiftL 0b1 idx)
-    CbSetB3R8 (B3 idx) r -> do
+    CbSetB3R8 (B3 idx) r -> {-# SCC "CbSetB3R8" #-} do
       v <- r8 r
       setR8 r $ v .|. shiftL 0b1 idx
   where
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
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs
index 9c3da8c..f0e8724 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs
@@ -4,7 +4,7 @@ module Fig.Emulator.GB.Test.Instr where
 import Control.Lens.TH (makeLenses)
 
 import Control.Lens ((^.))
-import Control.Monad.State (StateT(..))
+import Control.Monad.State.Strict (StateT(..))
 
 import Data.Word (Word8, Word16)
 import qualified Data.Aeson as Aeson
-- 
cgit v1.2.3