fb-emulator-gb: It's not as slow

12 files changed, 152 insertions, 146 deletions

diff --git a/fig-emulator-gb/fig-emulator-gb.cabal b/fig-emulator-gb/fig-emulator-gb.cabal
index 4a094c6..526419f 100644
--- a/fig-emulator-gb/fig-emulator-gb.cabal
+++ b/fig-emulator-gb/fig-emulator-gb.cabal
@@ -46,6 +46,7 @@ library
     Fig.Emulator.GB.CPU
     Fig.Emulator.GB.CPU.Instruction
     Fig.Emulator.GB.Bus
+    -- Fig.Emulator.GB.FastBus
     Fig.Emulator.GB.Component.ROM
     Fig.Emulator.GB.Component.RAM
     Fig.Emulator.GB.Component.Video
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB.hs b/fig-emulator-gb/src/Fig/Emulator/GB.hs
index 6f32682..cc68afe 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB.hs
@@ -1,5 +1,6 @@
 module Fig.Emulator.GB where
 
+import Prelude (error)
 import Fig.Prelude
 
 import System.IO (withFile, IOMode (WriteMode))
@@ -8,6 +9,9 @@ import Control.Lens ((.=), use)
 import Control.Monad (when)
 import Control.Monad.State.Strict (StateT(..))
 
+import qualified Data.Vector as V
+import qualified Data.ByteString as BS
+
 import qualified SDL
 
 import Fig.Emulator.GB.CPU
@@ -20,7 +24,7 @@ import Fig.Emulator.GB.Component.Joystick
 import Fig.Emulator.GB.Component.Serial
 import Fig.Emulator.GB.Component.Interrupt (compInterrupt)
 
-cpuDMG :: (MonadIO m, MonadThrow m) => Maybe Handle -> ByteString -> Framebuffer -> CPU m
+cpuDMG :: Maybe Handle -> ByteString -> Framebuffer -> CPU
 cpuDMG serial rom fb = CPU
   { _lastPC = 0x0
   , _lastIns = Nop
@@ -37,7 +41,7 @@ cpuDMG serial rom fb = CPU
     ]
   }
 
-testRun :: forall m. (MonadIO m, MonadThrow m) => Maybe FilePath -> ByteString -> m ()
+testRun :: Maybe FilePath -> ByteString -> IO ()
 testRun serialOut rom = do
   SDL.initializeAll
   window <- SDL.createWindow "taking" SDL.defaultWindow
@@ -48,7 +52,7 @@ testRun serialOut rom = do
   liftIO $ withSerial \hserial -> do
     let cpu = cpuDMG hserial rom fb
     let
-      loop :: forall m'. Emulating m' => Int -> m' ()
+      loop :: Int -> Emulating ()
       loop cycle = do
         -- events <- SDL.pollEvents
         -- forM_ events \ev ->
@@ -81,5 +85,5 @@ testRun serialOut rom = do
         --   SDL.updateWindowSurface window
         r <- use running
         when r . loop $ cycle + 1
-    void $ flip runStateT cpu do
+    void $ flip (runStateT . runEmulating) cpu do
       loop 0
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
index 6550d2d..1c64dfd 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
@@ -19,22 +19,22 @@ newtype Addr = Addr { unAddr :: Word16 }
 instance Pretty Addr where
   pretty (Addr w) = "$" <> pack (showHex w "")
 
-data Component m = forall (s :: Type). Component
+data Component = 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
+  , compUpdate :: s -> Int -> IO s
+  , compWrite :: s -> Addr -> Word8 -> IO s
+  , compRead :: s -> Addr -> IO Word8
   }
 
-newtype Bus m = Bus { busComponents :: [Component m] }
+newtype Bus = Bus { busComponents :: [Component] }
 
-update :: forall m. MonadIO m => Int -> Bus m -> m (Bus m)
+update :: Int -> Bus -> IO Bus
 update t b = Bus <$> forM (busComponents b) \Component{..} -> do
   s <- compUpdate compState t
   pure Component { compState = s, ..}
 
-write :: forall m. MonadIO m => Bus m -> Addr -> Word8 -> m (Bus m)
+write :: Bus -> Addr -> Word8 -> IO Bus
 write b a v = Bus <$> forM (busComponents b) \c@Component{..} ->
   if compMatches a
   then do
@@ -42,7 +42,7 @@ write b a v = Bus <$> forM (busComponents b) \c@Component{..} ->
     pure Component { compState = s, ..}
   else pure c
 
-read :: forall m. (MonadIO m, MonadThrow m) => Bus m -> Addr -> m (Maybe Word8)
+read :: Bus -> Addr -> IO (Maybe Word8)
 read b a = case List.find (`compMatches` a) $ busComponents b of
   Nothing -> pure Nothing
   Just Component{..} -> Just <$> compRead compState a
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
index 6f56324..9a6f557 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
@@ -2,7 +2,7 @@
 module Fig.Emulator.GB.CPU
   ( CPU(..)
   , Registers(..), initialRegs
-  , Emulating
+  , Emulating, runEmulating
   , running, regs, bus, regPC, regSP
   , regA, regB, regC, regD, regE, regH, regL
   , regFlagZ, regFlagN, regFlagH, regFlagC
@@ -17,6 +17,7 @@ import Fig.Prelude
 
 import Control.Lens ((.=), use, (^.))
 import Control.Monad (when)
+import Control.Monad.State.Strict (StateT(..))
 
 import Data.Word (Word8, Word16, Word32)
 import Data.Int (Int8)
@@ -62,17 +63,17 @@ initialRegs = Registers
   , _regFlagIME = False
   }
 
-data CPU m = CPU
+data CPU = CPU
   { _lastPC :: Word16
   , _lastIns :: Instruction
   , _running :: Bool
   , _regs :: Registers
-  , _bus :: Bus m
+  , _bus :: Bus
   }
 makeLenses 'CPU
 
-type EmulatingT f m = (MonadIO m, MonadThrow m, MonadState (CPU f) m)
-type Emulating m = EmulatingT IO m
+newtype Emulating a = Emulating { runEmulating :: StateT CPU IO a }
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState CPU, MonadThrow)
 
 -- logCPUState :: Emulating m => m ()
 -- logCPUState = do
@@ -100,30 +101,30 @@ type Emulating m = EmulatingT IO m
 --     rreg8 = pack . Pr.printf "%02X"
 --     rreg16 = pack . Pr.printf "%04X"
 
-updateComps :: Emulating m => Int -> m ()
+updateComps :: Int -> Emulating ()
 updateComps t = do
   b <- use bus
   b' <- liftIO $ Bus.update t b
   bus .= b'
 
-decode :: Emulating m => m Instruction
+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
 
-cond :: Emulating m => Cond -> m Bool
+cond :: Cond -> Emulating Bool
 cond CondNz = not <$> use (regs . regFlagZ)
 cond CondZ = use (regs . regFlagZ)
 cond CondNc = not <$> use (regs . regFlagC)
 cond CondC = use (regs . regFlagC)
 
-read8 :: Emulating m => Addr -> m Word8
+read8 :: Addr -> Emulating Word8
 read8 a = do
   -- updateComps 4
   b <- use bus
@@ -141,25 +142,25 @@ read8 a = do
       , ")"
       ]
 
-read16 :: Emulating m => Addr -> m Word16
+read16 :: Addr -> Emulating Word16
 read16 a = do
   lo <- read8 a
   hi <- read8 $ a + 1
   pure $ w8w8 hi lo
 
-write8 :: Emulating m => Addr -> Word8 -> m ()
+write8 :: Addr -> Word8 -> Emulating ()
 write8 a v = do
   -- updateComps 4
   b <- use bus
   b' <- liftIO $ Bus.write b a v
   bus .= b'
 
-write16 :: Emulating m => Addr -> Word16 -> m ()
+write16 :: Addr -> Word16 -> Emulating ()
 write16 a v = do
   write8 a $ w16lo v
   write8 (a + 1) $ w16hi v
 
-r8 :: Emulating m => R8 -> m Word8
+r8 :: R8 -> Emulating Word8
 r8 R8B = use $ regs . regB
 r8 R8C = use $ regs . regC
 r8 R8D = use $ regs . regD
@@ -171,7 +172,7 @@ r8 R8MemHL = do
   read8 $ Addr hl
 r8 R8A = use $ regs . regA
 
-setR8 :: Emulating m => R8 -> Word8 -> m ()
+setR8 :: R8 -> Word8 -> Emulating ()
 setR8 R8B v = regs . regB .= v
 setR8 R8C v = regs . regC .= v
 setR8 R8D v = regs . regD .= v
@@ -183,13 +184,13 @@ setR8 R8MemHL v = do
   write8 (Addr hl) v
 setR8 R8A v = regs . regA .= v
 
-r16 :: Emulating m => R16 -> m Word16
+r16 :: R16 -> Emulating Word16
 r16 R16BC = w8w8 <$> r8 R8B <*> r8 R8C
 r16 R16DE = w8w8 <$> r8 R8D <*> r8 R8E
 r16 R16HL = w8w8 <$> r8 R8H <*> r8 R8L
 r16 R16SP = use $ regs . regSP
 
-setR16 :: Emulating m => R16 -> Word16 -> m ()
+setR16 :: R16 -> Word16 -> Emulating ()
 setR16 R16BC v = do
   regs . regB .= w16hi v
   regs . regC .= w16lo v
@@ -201,7 +202,7 @@ setR16 R16HL v = do
   regs . regL .= w16lo v
 setR16 R16SP v = regs . regSP .= v
 
-r16Stk :: Emulating m => R16Stk -> m Word16
+r16Stk :: R16Stk -> Emulating Word16
 r16Stk R16StkBC = r16 R16BC
 r16Stk R16StkDE = r16 R16DE
 r16Stk R16StkHL = r16 R16HL
@@ -213,7 +214,7 @@ r16Stk R16StkAF = do
   c <- use $ regs . regFlagC
   pure . w8w8 hi $ flagsw8 z n h c
 
-setR16Stk :: Emulating m => R16Stk -> Word16 -> m ()
+setR16Stk :: R16Stk -> Word16 -> Emulating ()
 setR16Stk R16StkBC v = setR16 R16BC v
 setR16Stk R16StkDE v = setR16 R16DE v
 setR16Stk R16StkHL v = setR16 R16HL v
@@ -225,7 +226,7 @@ setR16Stk R16StkAF v = do
   regs . regFlagH .= w8bit 5 lo
   regs . regFlagC .= w8bit 4 lo
 
-r16Mem :: Emulating m => R16Mem -> m Word16
+r16Mem :: R16Mem -> Emulating Word16
 r16Mem R16MemBC = r16 R16BC
 r16Mem R16MemDE = r16 R16DE
 r16Mem R16MemHLPlus = do
@@ -237,10 +238,10 @@ r16Mem R16MemHLMinus = do
   setR16 R16HL $ hl - 1
   pure hl
 
-step :: forall m. Emulating m => Instruction -> m ()
+step :: Instruction -> Emulating ()
 step ins = do
   let
-    sub8 :: (Word16 -> Word16 -> Word16) -> Word8 -> Word8 -> m Word8
+    sub8 :: (Word16 -> Word16 -> Word16) -> Word8 -> Word8 -> Emulating Word8
     sub8 op x y = do
       let res = op (sext x) (sext y)
       regs . regFlagH .= (w8bits4 3 y > w8bits4 3 x)
@@ -248,7 +249,7 @@ step ins = do
       regs . regFlagZ .= (res .&. 0xff == 0)
       regs . regFlagN .= True
       pure $ trunc res
-    bitwise8 :: (Word8 -> Word8 -> Word8) -> Word8 -> Word8 -> m Word8
+    bitwise8 :: (Word8 -> Word8 -> Word8) -> Word8 -> Word8 -> Emulating Word8
     bitwise8 op x y = do
       let res = op x y
       regs . regFlagH .= False
@@ -679,7 +680,7 @@ step ins = do
       v <- r8 r
       setR8 r $ v .|. shiftL 0b1 idx
   where
-    unimplemented :: m ()
+    unimplemented :: Emulating ()
     unimplemented = do
       a <- use lastPC
       throwM . CPUError $ mconcat
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs
index b74a8ee..d7d9caa 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs
@@ -86,7 +86,7 @@ instance ExtractFromOpcode Tgt3 where
 
 newtype Imm8 = Imm8 Word8
   deriving (Show)
-readImm8 :: (MonadIO m, MonadThrow m) => Bus.Bus m -> Addr -> m Imm8
+readImm8 :: Bus.Bus -> Addr -> IO Imm8
 readImm8 b a = Bus.read b a >>= \case
   Just i -> pure $ Imm8 i
   Nothing -> throwM . DecodeError $ mconcat
@@ -96,7 +96,7 @@ readImm8 b a = Bus.read b a >>= \case
 
 newtype Imm16 = Imm16 Word16
   deriving (Show)
-readImm16 :: (MonadIO m, MonadThrow m) => Bus.Bus m -> Addr -> m Imm16
+readImm16 :: Bus.Bus -> Addr -> IO Imm16
 readImm16 b a = do
   mlo <- Bus.read b a
   mhi <- Bus.read b $ a + 1
@@ -207,106 +207,105 @@ data Instruction
   deriving (Show)
 
 readInstruction ::
-  (MonadIO m, MonadThrow m) =>
-  Bus.Bus m -> Addr ->
-  m (Instruction, Addr)
-readInstruction b a = do
-  op <- Bus.read b a >>= \case
+  Bus.Bus -> Addr ->
+  IO (Instruction, Addr)
+readInstruction b a = {-# SCC "TheWholeWorldOfDecodingcraft" #-} do
+  op <- {-# SCC "TheDecodeBusRead" #-} Bus.read b a >>= \case
     Just o -> pure o
     Nothing -> throwM . DecodeError $ mconcat
       [ "failed to read opcode at unmapped address "
       , pretty a
       ]
-  let blk = w8bits2 7 op
-  let bot3 = w8bits3 2 op
-  let bot4 = w8bits4 3 op
-  let no i = pure (i, a + 1)
-  let imm8 f = do
+  let blk = {-# SCC "TheDecodeBlk" #-} w8bits2 7 op
+  let bot3 = {-# SCC "TheDecodeBot3" #-} w8bits3 2 op
+  let bot4 = {-# SCC "TheDecodeBot4" #-} w8bits4 3 op
+  let no i = {-# SCC "TheDecodeNo" #-} pure (i, a + 1)
+  let imm8 f = {-# SCC "TheDecodeImm8" #-} do
         x <- readImm8 b $ a + 1
         pure (f x, a + 2)
-  let imm16 f = do
+  let imm16 f = {-# SCC "TheDecodeImm16" #-} do
         x <- readImm16 b $ a + 1
         pure (f x, a + 3)
-  case (op, blk, bot4, bot3) of
+  {-# SCC "TheBigDecodeCaseTbh" #-} case {-# SCC "TheDecodeTuple" #-} (op, blk, bot4, bot3) of
     -- Block 0
-    (0b00000000, _, _, _) -> no Nop
+    (0b00000000, _, _, _) -> {-# SCC "DecodeNop" #-} no Nop
 
-    (_, 0b00, 0b0001, _) -> imm16 $ LdR16Imm16 (ext $ w8bits2 5 op)
-    (_, 0b00, 0b0010, _) -> no $ LdR16MemA (ext $ w8bits2 5 op)
-    (_, 0b00, 0b1010, _) -> no $ LdAR16Mem (ext $ w8bits2 5 op)
-    (0b00001000, _, _, _) -> imm16 LdImm16Sp
+    (_, 0b00, 0b0001, _) -> {-# SCC "DecodeLdR16Imm16" #-} imm16 $ LdR16Imm16 (ext $ w8bits2 5 op)
+    (_, 0b00, 0b0010, _) -> {-# SCC "DecodeLdR16MemA" #-} no $ LdR16MemA (ext $ w8bits2 5 op)
+    (_, 0b00, 0b1010, _) -> {-# SCC "DecodeLdAR16Mem" #-} no $ LdAR16Mem (ext $ w8bits2 5 op)
+    (0b00001000, _, _, _) -> {-# SCC "DecodeLdImm16Sp" #-} imm16 LdImm16Sp
 
-    (_, 0b00, 0b0011, _) -> no $ IncR16 (ext $ w8bits2 5 op)
-    (_, 0b00, 0b1011, _) -> no $ DecR16 (ext $ w8bits2 5 op)
-    (_, 0b00, 0b1001, _) -> no $ AddHlR16 (ext $ w8bits2 5 op)
+    (_, 0b00, 0b0011, _) -> {-# SCC "DecodeIncR16" #-} no $ IncR16 (ext $ w8bits2 5 op)
+    (_, 0b00, 0b1011, _) -> {-# SCC "DecodeDecR16" #-} no $ DecR16 (ext $ w8bits2 5 op)
+    (_, 0b00, 0b1001, _) -> {-# SCC "DecodeAddHlR16" #-} no $ AddHlR16 (ext $ w8bits2 5 op)
 
-    (_, 0b00, _, 0b100) -> no $ IncR8 (ext $ w8bits3 5 op)
-    (_, 0b00, _, 0b101) -> no $ DecR8 (ext $ w8bits3 5 op)
+    (_, 0b00, _, 0b100) -> {-# SCC "DecodeIncR8" #-} no $ IncR8 (ext $ w8bits3 5 op)
+    (_, 0b00, _, 0b101) -> {-# SCC "DecodeDecR8" #-} no $ DecR8 (ext $ w8bits3 5 op)
 
-    (_, 0b00, _, 0b110) -> imm8 $ LdR8Imm8 (ext $ w8bits3 5 op)
+    (_, 0b00, _, 0b110) -> {-# SCC "DecodeLdR8Imm8" #-} imm8 $ LdR8Imm8 (ext $ w8bits3 5 op)
 
-    (0b00000111, _, _, _) -> no Rlca
-    (0b00001111, _, _, _) -> no Rrca
-    (0b00010111, _, _, _) -> no Rla
-    (0b00011111, _, _, _) -> no Rra
-    (0b00100111, _, _, _) -> no Daa
-    (0b00101111, _, _, _) -> no Cpl
-    (0b00110111, _, _, _) -> no Scf
-    (0b00111111, _, _, _) -> no Ccf
+    (0b00000111, _, _, _) -> {-# SCC "DecodeRlca" #-} no Rlca
+    (0b00001111, _, _, _) -> {-# SCC "DecodeRrca" #-} no Rrca
+    (0b00010111, _, _, _) -> {-# SCC "DecodeRla" #-} no Rla
+    (0b00011111, _, _, _) -> {-# SCC "DecodeRra" #-} no Rra
+    (0b00100111, _, _, _) -> {-# SCC "DecodeDaa" #-} no Daa
+    (0b00101111, _, _, _) -> {-# SCC "DecodeCpl" #-} no Cpl
+    (0b00110111, _, _, _) -> {-# SCC "DecodeScf" #-} no Scf
+    (0b00111111, _, _, _) -> {-# SCC "DecodeCcf" #-} no Ccf
 
-    (0b00011000, _, _, _) -> imm8 JrImm8
-    (0b00010000, _, _, _) -> no Stop
-    (_, 0b00, _, 0b000) -> imm8 $ JrCondImm8 (ext $ w8bits2 4 op)
+    (0b00011000, _, _, _) -> {-# SCC "DecodeJrImm8" #-} imm8 JrImm8
+    (0b00010000, _, _, _) -> {-# SCC "DecodeStop" #-} no Stop
+    (_, 0b00, _, 0b000) -> {-# SCC "DecodeJrCondImm8" #-} imm8 $ JrCondImm8 (ext $ w8bits2 4 op)
 
     -- Block 1
-    (0b01110110, _, _, _) -> no Halt
-    (_, 0b01, _, _) -> no $ LdR8R8 (ext $ w8bits3 5 op) (ext $ w8bits3 2 op)
+    (0b01110110, _, _, _) -> {-# SCC "DecodeHalt" #-} no Halt
+    (_, 0b01, _, _) -> {-# SCC "DecodeLdR8R8" #-} no $ LdR8R8 (ext $ w8bits3 5 op) (ext $ w8bits3 2 op)
 
     -- Block 2
     (_, 0b10, _, _) -> do
       let ins = case w8bits3 5 op of
-            0b000 -> AddAR8
-            0b001 -> AdcAR8
-            0b010 -> SubAR8
-            0b011 -> SbcAR8
-            0b100 -> AndAR8
-            0b101 -> XorAR8
-            0b110 -> OrAR8
-            0b111 -> CpAR8
+            0b000 -> {-# SCC "DecodeAddAR8" #-} AddAR8
+            0b001 -> {-# SCC "DecodeAdcAR8" #-} AdcAR8
+            0b010 -> {-# SCC "DecodeSubAR8" #-} SubAR8
+            0b011 -> {-# SCC "DecodeSbcAR8" #-} SbcAR8
+            0b100 -> {-# SCC "DecodeAndAR8" #-} AndAR8
+            0b101 -> {-# SCC "DecodeXorAR8" #-} XorAR8
+            0b110 -> {-# SCC "DecodeOrAR8" #-} OrAR8
+            0b111 -> {-# SCC "DecodeCpAR8" #-} CpAR8
             _ -> error "unreachable"
       no $ ins (ext $ w8bits3 2 op)
 
     -- Block 3
-    (0b11000110, _, _, _) -> imm8 AddAImm8
-    (0b11001110, _, _, _) -> imm8 AdcAImm8
-    (0b11010110, _, _, _) -> imm8 SubAImm8
-    (0b11011110, _, _, _) -> imm8 SbcAImm8
-    (0b11100110, _, _, _) -> imm8 AndAImm8
-    (0b11101110, _, _, _) -> imm8 XorAImm8
-    (0b11110110, _, _, _) -> imm8 OrAImm8
-    (0b11111110, _, _, _) -> imm8 CpAImm8
-
-    (0b11001001, _, _, _) -> no Ret
-    (0b11011001, _, _, _) -> no Reti
-    (0b11000011, _, _, _) -> imm16 JpImm16
-    (0b11101001, _, _, _) -> no JpHl
-    (0b11001101, _, _, _) -> imm16 CallImm16
-
-    (0b11100010, _, _, _) -> no LdhCA
-    (0b11100000, _, _, _) -> imm8 LdhImm8A
-    (0b11101010, _, _, _) -> imm16 LdImm16A
-    (0b11110010, _, _, _) -> no LdhAC
-    (0b11110000, _, _, _) -> imm8 LdhAImm8
-    (0b11111010, _, _, _) -> imm16 LdAImm16
-
-    (0b11101000, _, _, _) -> imm8 AddSpImm8
-    (0b11111000, _, _, _) -> imm8 LdHlSpPlusImm8
-    (0b11111001, _, _, _) -> no LdSpHl
-
-    (0b11110011, _, _, _) -> no Di
-    (0b11111011, _, _, _) -> no Ei
-
-    (0b11001011, _, _, _) -> do
+    (0b11000110, _, _, _) -> {-# SCC "DecodeAddAImm8" #-} imm8 AddAImm8
+    (0b11001110, _, _, _) -> {-# SCC "DecodeAdcAImm8" #-} imm8 AdcAImm8
+    (0b11010110, _, _, _) -> {-# SCC "DecodeSubAImm8" #-} imm8 SubAImm8
+    (0b11011110, _, _, _) -> {-# SCC "DecodeSbcAImm8" #-} imm8 SbcAImm8
+    (0b11100110, _, _, _) -> {-# SCC "DecodeAndAImm8" #-} imm8 AndAImm8
+    (0b11101110, _, _, _) -> {-# SCC "DecodeXorAImm8" #-} imm8 XorAImm8
+    (0b11110110, _, _, _) -> {-# SCC "DecodeOrAImm8" #-} imm8 OrAImm8
+    (0b11111110, _, _, _) -> {-# SCC "DecodeCpAImm8" #-} imm8 CpAImm8
+
+    (0b11001001, _, _, _) -> {-# SCC "DecodeRet" #-} no Ret
+    (0b11011001, _, _, _) -> {-# SCC "DecodeReti" #-} no Reti
+    (0b11000011, _, _, _) -> {-# SCC "DecodeJpImm16" #-} imm16 JpImm16
+    (0b11101001, _, _, _) -> {-# SCC "DecodeJpHl" #-} no JpHl
+    (0b11001101, _, _, _) -> {-# SCC "DecodeCallImm16" #-} imm16 CallImm16
+
+    (0b11100010, _, _, _) -> {-# SCC "DecodeLdhCA" #-} no LdhCA
+    (0b11100000, _, _, _) -> {-# SCC "DecodeLdhImm8A" #-} imm8 LdhImm8A
+    (0b11101010, _, _, _) -> {-# SCC "DecodeLdImm16A" #-} imm16 LdImm16A
+    (0b11110010, _, _, _) -> {-# SCC "DecodeLdhAC" #-} no LdhAC
+    (0b11110000, _, _, _) -> {-# SCC "DecodeLdhAImm8" #-} imm8 LdhAImm8
+    (0b11111010, _, _, _) -> {-# SCC "DecodeLdAImm16" #-} imm16 LdAImm16
+
+    (0b11101000, _, _, _) -> {-# SCC "DecodeAddSpImm8" #-} imm8 AddSpImm8
+    (0b11111000, _, _, _) -> {-# SCC "DecodeLdHlSpPlusImm8" #-} imm8 LdHlSpPlusImm8
+    (0b11111001, _, _, _) -> {-# SCC "DecodeLdSpHl" #-} no LdSpHl
+
+    (0b11110011, _, _, _) -> {-# SCC "DecodeDi" #-} no Di
+    (0b11111011, _, _, _) -> {-# SCC "DecodeEi" #-} no Ei
+
+    (0b11001011, _, _, _) -> {-# SCC "DecodeCBPrefix" #-} do
       -- 0xcb prefix
       op2 <- Bus.read b (a + 1) >>= \case
         Just o -> pure o
@@ -317,26 +316,26 @@ readInstruction b a = do
       case w8bits2 7 op2 of
 
         0b00 -> case w8bits3 5 op2 of
-          0b000 -> pure (CbRlcR8 $ ext $ w8bits3 2 op2, a + 2)
-          0b001 -> pure (CbRrcR8 $ ext $ w8bits3 2 op2, a + 2)
-          0b010 -> pure (CbRlR8 $ ext $ w8bits3 2 op2, a + 2)
-          0b011 -> pure (CbRrR8 $ ext $ w8bits3 2 op2, a + 2)
-          0b100 -> pure (CbSlaR8 $ ext $ w8bits3 2 op2, a + 2)
-          0b101 -> pure (CbSraR8 $ ext $ w8bits3 2 op2, a + 2)
-          0b110 -> pure (CbSwapR8 $ ext $ w8bits3 2 op2, a + 2)
-          0b111 -> pure (CbSrlR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b000 -> {-# SCC "DecodeCbRlcR8" #-} pure (CbRlcR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b001 -> {-# SCC "DecodeCbRrcR8" #-} pure (CbRrcR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b010 -> {-# SCC "DecodeCbRlR8" #-} pure (CbRlR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b011 -> {-# SCC "DecodeCbRrR8" #-} pure (CbRrR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b100 -> {-# SCC "DecodeCbSlaR8" #-} pure (CbSlaR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b101 -> {-# SCC "DecodeCbSraR8" #-} pure (CbSraR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b110 -> {-# SCC "DecodeCbSwapR8" #-} pure (CbSwapR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b111 -> {-# SCC "DecodeCbSrlR8" #-} pure (CbSrlR8 $ ext $ w8bits3 2 op2, a + 2)
           _ -> error "unreachable"
-        0b01 -> pure (CbBitB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
-        0b10 -> pure (CbResB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
-        0b11 -> pure (CbSetB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
+        0b01 -> {-# SCC "DecodeCbBitB3R8" #-} pure (CbBitB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
+        0b10 -> {-# SCC "DecodeCbResB3R8" #-} pure (CbResB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
+        0b11 -> {-# SCC "DecodeCbSetB3R8" #-} pure (CbSetB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
         _ -> error "unreachable"
 
-    (_, 0b11, _, 0b000) -> no $ RetCond (ext $ w8bits2 4 op)
-    (_, 0b11, _, 0b010) -> imm16 $ JpCondImm16 (ext $ w8bits2 4 op)
-    (_, 0b11, _, 0b100) -> imm16 $ CallCondImm16 (ext $ w8bits2 4 op)
-    (_, 0b11, _, 0b111) -> no $ RstTgt3 (ext $ w8bits3 5 op)
-    (_, 0b11, 0b0001, _) -> no $ PopR16Stk (ext $ w8bits2 5 op)
-    (_, 0b11, 0b0101, _) -> no $ PushR16Stk (ext $ w8bits2 5 op)
+    (_, 0b11, _, 0b000) -> {-# SCC "DecodeRetCond" #-} no $ RetCond (ext $ w8bits2 4 op)
+    (_, 0b11, _, 0b010) -> {-# SCC "DecodeJpCondImm16" #-} imm16 $ JpCondImm16 (ext $ w8bits2 4 op)
+    (_, 0b11, _, 0b100) -> {-# SCC "DecodeCallCondImm16" #-} imm16 $ CallCondImm16 (ext $ w8bits2 4 op)
+    (_, 0b11, _, 0b111) -> {-# SCC "DecodeRstTgt3" #-} no $ RstTgt3 (ext $ w8bits3 5 op)
+    (_, 0b11, 0b0001, _) -> {-# SCC "DecodePopR16Stk" #-} no $ PopR16Stk (ext $ w8bits2 5 op)
+    (_, 0b11, 0b0101, _) -> {-# SCC "DecodePushR16Stk" #-} no $ PushR16Stk (ext $ w8bits2 5 op)
 
     _unknown -> do
       log $ "unknown opcode: " <> tshow op
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs
index ec5540c..f6ea420 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs
@@ -14,7 +14,7 @@ instance Pretty InterruptError where
     , b
     ]
 
-compInterrupt :: (MonadIO m, MonadThrow m) => Component m
+compInterrupt :: Component
 compInterrupt = Component
   { compState = ()
   , compMatches = \a -> a == 0xff0f || a == 0xffff
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs
index 84785b6..7519ea5 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs
@@ -13,7 +13,7 @@ instance Pretty JoystickError where
     , b
     ]
 
-compJoystick :: (MonadIO m, MonadThrow m) => Component m
+compJoystick :: Component
 compJoystick = Component
   { compState = ()
   , compMatches = (== 0xff00)
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 b17292c..4dc5715 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
@@ -19,7 +19,7 @@ instance Pretty RAMError where
     , b
     ]
 
-compWRAM :: (MonadIO m, MonadThrow m) => Addr -> Int -> Component m
+compWRAM :: Addr -> Int -> Component
 compWRAM start size = Component
   { compState = V.replicate size 0 :: V.Vector Word8
   , compMatches = \a ->
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
index bfdc2fb..6aafc46 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
@@ -20,7 +20,7 @@ instance Pretty ROMError where
     ]
 
 -- | Initialize base ROM (no mapper) from a ByteString
-compROM :: (MonadIO m, MonadThrow m) => ByteString -> Component m
+compROM :: ByteString -> Component
 compROM bs = Component
   { compState = V.fromList $ BS.unpack bs
   , compMatches = \a ->
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 0ee529b..7a4bceb 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs
@@ -18,7 +18,7 @@ instance Pretty SerialError where
     , b
     ]
 
-compSerial :: (MonadIO m, MonadThrow m) => Maybe Handle -> Component m
+compSerial :: Maybe Handle -> Component
 compSerial mh = Component
   { compState = ()
   , compMatches = (== 0xff01)
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 9326e41..2337a1c 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
@@ -36,7 +36,7 @@ newtype Framebuffer = Framebuffer
   { fbSurface :: SDL.Surface
   }
 
-initializeFramebuffer :: MonadIO m => m Framebuffer
+initializeFramebuffer :: IO Framebuffer
 initializeFramebuffer = do
   s <- liftIO $ SDL.createRGBSurface
     (SDL.V2 (fromIntegral screenWidth) $ fromIntegral screenHeight)
@@ -45,7 +45,7 @@ initializeFramebuffer = do
     { fbSurface = s
     }
 
-logTilemap :: MonadIO m => V.Vector Word8 -> m ()
+logTilemap :: V.Vector Word8 -> IO ()
 logTilemap v = do
   let base = 0x9800 - 0x8000
   bytes <- forM ([0..(32 * 32)] :: [Int]) \i -> do
@@ -54,7 +54,7 @@ logTilemap v = do
       Just a -> pure a
   log $ "tilemap:" <> tshow bytes
 
-blitPixel :: MonadIO m => Word32 -> (Word8, Word8) -> Framebuffer -> m ()
+blitPixel :: Word32 -> (Word8, Word8) -> Framebuffer -> IO ()
 blitPixel c (x, y) fb = do
   SDL.lockSurface $ fbSurface fb
   (base :: Ptr.Ptr Word32) <- Ptr.castPtr <$> SDL.surfacePixels (fbSurface fb)
@@ -64,7 +64,7 @@ blitPixel c (x, y) fb = do
   liftIO $ St.poke p c
   SDL.unlockSurface $ fbSurface fb
 
-blitTile :: (MonadIO m, MonadThrow m) => V.Vector Word8 -> Addr -> (Word8, Word8) -> Framebuffer -> m ()
+blitTile :: V.Vector Word8 -> Addr -> (Word8, Word8) -> Framebuffer -> IO ()
 blitTile v (Addr a) (bx, by) fb = do
   (ps :: [(Word8, Word8, Word8)]) <- mconcat <$> forM [0..7] \y -> do
     mconcat <$> forM [0..1] \xb -> do
@@ -120,7 +120,7 @@ data VideoState = VideoState
   , vstTick :: Word16
   }
 
-compVideo :: (MonadIO m, MonadThrow m) => Framebuffer -> Component m
+compVideo :: Framebuffer -> Component
 compVideo framebuffer = Component
   { compState = VideoState
     { vstFb = framebuffer
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 f0e8724..647e03a 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Test/Instr.hs
@@ -7,6 +7,7 @@ import Control.Lens ((^.))
 import Control.Monad.State.Strict (StateT(..))
 
 import Data.Word (Word8, Word16)
+import qualified Data.Vector as V
 import qualified Data.Aeson as Aeson
 
 import qualified Text.Printf as Pr
@@ -71,12 +72,12 @@ instance Aeson.FromJSON Testcase where
     _testcaseFinal <- v Aeson..: "final"
     pure Testcase {..}
 
-readTestcases :: (MonadIO m, MonadThrow m) => FilePath -> m [Testcase]
+readTestcases :: FilePath -> IO [Testcase]
 readTestcases p = liftIO (Aeson.decodeFileStrict p) >>= \case
   Just ts -> pure ts
   Nothing -> throwM . InstrTestError $ "failed to read testcases at " <> pack p
 
-cpuInstrTest :: (MonadIO m, MonadThrow m) => TestVals -> m (CPU m)
+cpuInstrTest :: TestVals -> IO CPU
 cpuInstrTest vs = do
   let
     (z, n, h, c) = w8flags $ vs ^. testvalsF
@@ -104,7 +105,7 @@ cpuInstrTest vs = do
     , _bus = finalBus
     }
 
-checkCPU :: forall m. (MonadIO m, MonadThrow m) => Text -> TestVals -> CPU m -> CPU m -> m ()
+checkCPU :: Text -> TestVals -> CPU -> CPU -> IO ()
 checkCPU tnm vs initial c = do
   let
     flag f = if f then "1" else "0"
@@ -131,7 +132,7 @@ checkCPU tnm vs initial c = do
       , ", H: ", flag $ r ^. regFlagH
       , ", C: ", flag $ r ^. regFlagC
       ]
-    check :: (Eq a) => (a -> Text) -> Text -> a -> a -> m ()
+    check :: (Eq a) => (a -> Text) -> Text -> a -> a -> IO ()
     check pr nm eval aval = if eval == aval
       then pure ()
       else throwM . InstrTestError $ mconcat
@@ -162,14 +163,14 @@ checkCPU tnm vs initial c = do
       Nothing -> throwM . InstrTestError $ "failed to read expected address: " <> pretty addr
       Just aval -> check rreg8 ("memory address " <> pretty addr) eval aval
 
-runTestcase :: (MonadIO m, MonadThrow m) => Testcase -> m ()
+runTestcase :: Testcase -> IO ()
 runTestcase tc = liftIO do
   initial <- cpuInstrTest $ tc ^. testcaseInitial
   let
-    body :: forall m'. Emulating m' => m' Instruction
+    body :: Emulating Instruction
     body = do
       ins <- decode
       step ins
       pure ins
-  (ins, final) <- runStateT body initial
+  (ins, final) <- runStateT (runEmulating body) initial
   checkCPU (tc ^. testcaseName <> " (" <> tshow ins <> ")") (tc ^. testcaseFinal) initial final