Handling IRQs and NMIs properly

funes.cabal

@@ -69,6 +69,7 @@ library
       Nes.CPU.Instructions.Transfer
       Nes.CPU.Instructions.Unofficial
       Nes.CPU.Interpreter
+      Nes.CPU.Interrupt
       Nes.CPU.Monad
       Nes.CPU.State
       Nes.FlagRegister

src/Nes/APU/BusInterface/DMC.hs

@@ -15,7 +15,7 @@ write4010 byte = do
         rate = getPeriodValue rateIdx
     modifyAPUState $ modifyDMC $ \dmc ->
         dmc
-            { irqEnabledFlag = irq
+            { interruptFlag = irq
             , loopFlag = loop
             , period = rate
             }

src/Nes/APU/BusInterface/FrameCounter.hs

@@ -19,6 +19,10 @@ write4017 byte = do
     modifyAPUState $
         modifyFrameCounter $
             \fc -> fc{sequenceMode = seqMode, inhibitInterrupt = inhibit, delayedWriteSideEffectCycle = Just delay}
+    when (seqMode == FiveStep) $ do
+        runQuarterFrameEvent
+        runHalfFrameEvent
+
     -- If the mode flag is set, then both "quarter frame" and "half frame" signals are also generated
     when inhibit $ do
         setFrameInterruptFlag False

src/Nes/APU/BusInterface/Status.hs

@@ -5,10 +5,10 @@ import Data.Bits
 import Nes.APU.Monad
 import Nes.APU.State
 import Nes.APU.State.DMC
+import Nes.APU.State.FrameCounter (FrameCounter (frameInterruptFlag))
 import Nes.APU.State.LengthCounter
 import Nes.APU.Tick (setFrameInterruptFlag)
-import Nes.Bus.SideEffect
-import Nes.FlagRegister (getFlag)
+import Nes.Interrupt
 import Nes.Memory
 
 {-# INLINE write4015 #-}
@@ -45,21 +45,26 @@ read4015 = do
     pulse1Bit <- withAPUState $ lengthCounterBit . pulse1
     pulse2Bit <- withAPUState $ lengthCounterBit . pulse2
     dmcBit <- withAPUState $ \st -> sampleBytesRemaining (dmc st) > 0
-    frameInterruptBit <- withSideEffect $ getFlag IRQ
-    dmcInterruptBit <- withSideEffect $ getFlag DMCDMA
+    frameInterruptBit <- withAPUState $ frameInterruptFlag . frameCounter
+    dmcInterruptBit <- withInterruptStatus $ (== Just DMC) . irq
+    -- TODO Clearing flag should be done on every GET cycle
+    -- https://github.com/100thCoin/AccuracyCoin/blob/a7bf0cfaee7dee9e7bfbd0e30435b85cb539139e/AccuracyCoin.asm#L9003
     when frameInterruptBit $ do
         setFrameInterruptFlag False
-    return $
-        setBit' dmcInterruptBit 7 $
-            setBit' frameInterruptBit 6 $
-                setBit' dmcBit 4 $
-                    setBit' noiseBit 3 $
-                        setBit' triangleBit 2 $
-                            setBit' pulse2Bit 1 $
-                                setBit'
-                                    pulse1Bit
-                                    0
-                                    0
+    let res =
+            setBit' dmcInterruptBit 7 $
+                setBit' frameInterruptBit 6 $
+                    setBit' dmcBit 4 $
+                        setBit' noiseBit 3 $
+                            setBit' triangleBit 2 $
+                                setBit' pulse2Bit 1 $
+                                    setBit'
+                                        pulse1Bit
+                                        0
+                                        0
+    return res
   where
     setBit' b i a = if b then a `setBit` i else a `clearBit` i
-    lengthCounterBit st = let lc = getLengthCounter st in isEnabled lc
+    lengthCounterBit st =
+        let lc = getLengthCounter st
+         in isEnabled lc && not (isSilencedByLengthCounter st)

src/Nes/APU/Monad.hs

@@ -2,70 +2,70 @@ module Nes.APU.Monad (
     APU (..),
     runAPU,
     modifyAPUState,
-    modifyAPUStateWithSideEffect,
+    modifyAPUStateWithInterrupt,
     withAPUState,
     modifyFilterChain,
-    setSideEffect,
-    withSideEffect,
+    modifyInterruptStatus,
+    withInterruptStatus,
 ) where
 
 import Control.Monad.IO.Class
 import Nes.APU.State
 import Nes.APU.State.Filter.Chain (FilterChain)
-import Nes.Bus.SideEffect
+import Nes.Interrupt
 
 newtype APU r a = MkAPU
-    { unAPU :: APUState -> CPUSideEffect -> (APUState -> CPUSideEffect -> a -> IO r) -> IO r
+    { unAPU :: APUState -> InterruptStatus -> (APUState -> InterruptStatus -> a -> IO r) -> IO r
     }
     deriving (Functor)
 
 instance Applicative (APU r) where
     {-# INLINE pure #-}
-    pure a = MkAPU $ \(!st) (!cpuEff) cont -> cont st cpuEff a
+    pure a = MkAPU $ \(!st) (!interr) cont -> cont st interr a
 
     {-# INLINE liftA2 #-}
-    liftA2 f (MkAPU a) (MkAPU b) = MkAPU $ \(!st) (!cpuEff) cont ->
-        a st cpuEff $ \(!st') (!cpuEff') !a' -> b st' cpuEff' $ \(!st'') (!cpuEff'') !b' -> cont st'' cpuEff'' (f a' b')
+    liftA2 f (MkAPU a) (MkAPU b) = MkAPU $ \(!st) (!interr) cont ->
+        a st interr $ \(!st') (!interr') !a' -> b st' interr' $ \(!st'') (!interr'') !b' -> cont st'' interr'' (f a' b')
 
 instance Monad (APU r) where
     {-# INLINE (>>=) #-}
-    (MkAPU a) >>= next = MkAPU $ \st cpuEff cont ->
-        a st cpuEff $ \(!st') (!cpuEff') (!a') -> unAPU (next a') st' cpuEff' cont
+    (MkAPU a) >>= next = MkAPU $ \st interr cont ->
+        a st interr $ \(!st') (!interr') (!a') -> unAPU (next a') st' interr' cont
 
 instance MonadIO (APU r) where
     {-# INLINE liftIO #-}
-    liftIO io = MkAPU $ \st cpuEff cont -> io >>= cont st cpuEff
+    liftIO io = MkAPU $ \st interr cont -> io >>= cont st interr
 
 instance MonadFail (APU r) where
     {-# INLINE fail #-}
     fail = liftIO . fail
 
 {-# INLINE runAPU #-}
-runAPU :: APUState -> APU (a, APUState, CPUSideEffect) a -> IO (a, APUState, CPUSideEffect)
-runAPU !st f = unAPU f st mempty $ \(!st') (!cpuEff) a -> return (a, st', cpuEff)
+runAPU :: APUState -> InterruptStatus -> APU (a, APUState, InterruptStatus) a -> IO (a, APUState, InterruptStatus)
+runAPU !st !s f = unAPU f st s $ \(!st') (!interr) a -> return (a, st', interr)
 
 {-# INLINE modifyAPUState #-}
 modifyAPUState :: (APUState -> APUState) -> APU r ()
-modifyAPUState f = MkAPU $ \(!st) (!cpuEff) cont -> cont (f st) cpuEff ()
+modifyAPUState f = MkAPU $ \(!st) (!interr) cont -> cont (f st) interr ()
 
-{-# INLINE modifyAPUStateWithSideEffect #-}
-modifyAPUStateWithSideEffect :: (APUState -> (APUState, CPUSideEffect)) -> APU r ()
-modifyAPUStateWithSideEffect f = MkAPU $ \(!st) !cpuEff cont ->
-    let (st', sideEff) = f st in cont st' (cpuEff <> sideEff) ()
+{-# INLINE modifyAPUStateWithInterrupt #-}
+modifyAPUStateWithInterrupt :: (APUState -> InterruptStatus -> (APUState, InterruptStatus)) -> APU r ()
+modifyAPUStateWithInterrupt f = MkAPU $ \(!st) !interr cont ->
+    let (st', interr') = f st interr in cont st' interr' ()
 
 {-# INLINE withAPUState #-}
 withAPUState :: (APUState -> a) -> APU r a
-withAPUState f = MkAPU $ \(!st) !cpuEff cont -> cont st cpuEff (f st)
+withAPUState f = MkAPU $ \(!st) !interr cont -> cont st interr (f st)
 
 {-# INLINE modifyFilterChain #-}
 modifyFilterChain :: (FilterChain -> FilterChain) -> APU r ()
-modifyFilterChain f = MkAPU $ \(!st) !cpuEff cont ->
-    cont st{filterChain = f $ filterChain st} cpuEff ()
+modifyFilterChain f = MkAPU $ \(!st) !interr cont ->
+    cont st{filterChain = f $ filterChain st} interr ()
 
-{-# INLINE setSideEffect #-}
-setSideEffect :: (CPUSideEffect -> CPUSideEffect) -> APU r ()
-setSideEffect f = MkAPU $ \(!st) !cpuEff cont -> cont st (f cpuEff) ()
+{-# INLINE modifyInterruptStatus #-}
+modifyInterruptStatus :: (InterruptStatus -> InterruptStatus) -> APU r ()
+modifyInterruptStatus f = MkAPU $ \(!st) !interrupt cont -> cont st (f interrupt) ()
 
-{-# INLINE withSideEffect #-}
-withSideEffect :: (CPUSideEffect -> a) -> APU r a
-withSideEffect f = MkAPU $ \(!st) !cpuEff cont -> cont st cpuEff (f cpuEff)
+{-# INLINE withInterruptStatus #-}
+withInterruptStatus :: (InterruptStatus -> a) -> APU r a
+withInterruptStatus f = MkAPU $ \(!st) !interrupt cont -> cont st interrupt (f interrupt)

src/Nes/APU/State.hs

@@ -22,7 +22,7 @@ import Nes.APU.State.FrameCounter
 import Nes.APU.State.Noise
 import Nes.APU.State.Pulse
 import Nes.APU.State.Triangle
-import Nes.Bus.SideEffect (CPUSideEffect)
+import Nes.Interrupt (InterruptStatus)
 import Prelude hiding (cycle)
 
 data APUState = MkAPUState
@@ -77,8 +77,8 @@ modifyDMC :: (DMC -> DMC) -> APUState -> APUState
 modifyDMC f st = let dmc' = f $ dmc st in st{dmc = dmc'}
 
 {-# INLINE modifyDMC' #-}
-modifyDMC' :: (DMC -> (DMC, CPUSideEffect)) -> APUState -> (APUState, CPUSideEffect)
-modifyDMC' f st = let (dmc', sideEff) = f $ dmc st in (st{dmc = dmc'}, sideEff)
+modifyDMC' :: (DMC -> InterruptStatus -> (DMC, InterruptStatus)) -> APUState -> InterruptStatus -> (APUState, InterruptStatus)
+modifyDMC' f st s = let (dmc', s') = f (dmc st) s in (st{dmc = dmc'}, s')
 
 {-# INLINE modifyFrameCounter #-}
 modifyFrameCounter :: (FrameCounter -> FrameCounter) -> APUState -> APUState

src/Nes/APU/State/DMC.hs

@@ -18,12 +18,11 @@ import Data.Array
 import Data.Bits
 import Data.List ((!?))
 import Data.Maybe (fromMaybe, isNothing)
-import Nes.Bus.SideEffect
-import Nes.FlagRegister
+import Nes.Interrupt
 import Nes.Memory
 
 data DMC = MkDMC
-    { irqEnabledFlag :: {-# UNPACK #-} !Bool
+    { interruptFlag :: {-# UNPACK #-} !Bool
     , loopFlag :: {-# UNPACK #-} !Bool
     , period :: {-# UNPACK #-} !Int
     , timer :: {-# UNPACK #-} !Int
@@ -44,7 +43,7 @@ data DMC = MkDMC
 newDMC :: DMC
 newDMC = MkDMC{..}
   where
-    irqEnabledFlag = False
+    interruptFlag = False
     loopFlag = False
     period = 0
     timer = 0
@@ -61,8 +60,11 @@ newDMC = MkDMC{..}
     shouldClock = False
     sleepingCycles = 0
 
+periodTable :: [Int]
+periodTable = [428, 380, 340, 320, 286, 254, 226, 214, 190, 160, 142, 128, 106, 84, 72, 54]
+
 getPeriodValue :: Int -> Int
-getPeriodValue idx = fromMaybe 428 ([428, 380, 340, 286, 254, 226, 214, 190, 160, 142, 128, 106, 84, 72, 54] !? idx)
+getPeriodValue idx = fromMaybe 428 (periodTable !? idx)
 
 -- | When a sample is (re)started, the current address is set to the sample address, and bytes remaining is set to the sample length.
 restartSample :: DMC -> DMC
@@ -77,9 +79,9 @@ restartSample dmc =
 getDMCOutput :: DMC -> Int
 getDMCOutput dmc = if silentFlag dmc then 0 else outputLevel dmc
 
-tickDMC :: DMC -> (DMC, CPUSideEffect)
-tickDMC dmc =
-    (if clocks then tickOutputUnit else (,mempty))
+tickDMC :: DMC -> InterruptStatus -> (DMC, InterruptStatus)
+tickDMC dmc s =
+    (if clocks then (`tickOutputUnit` s) else (,s))
         dmc
             { timer = newTimer
             , outputLevel = newOutputLevel
@@ -97,25 +99,31 @@ tickDMC dmc =
                  in if (0, 127) `inRange` tmpOutLevel then tmpOutLevel else outputLevel dmc
             else outputLevel dmc
 
-tickOutputUnit :: DMC -> (DMC, CPUSideEffect)
-tickOutputUnit dmc = if isEndOfOutputCycle then onOutputCycleEnd dmc1 else (dmc1, mempty)
+tickOutputUnit :: DMC -> InterruptStatus -> (DMC, InterruptStatus)
+tickOutputUnit dmc s =
+    if isEndOfOutputCycle
+        then onOutputCycleEnd dmc1 s
+        else (dmc1, s)
   where
     newRemainingBits = max 0 (remainingBits dmc - 1)
     isEndOfOutputCycle = newRemainingBits == 0
     dmc1 = dmc{remainingBits = newRemainingBits}
 
-onOutputCycleEnd :: DMC -> (DMC, CPUSideEffect)
-onOutputCycleEnd dmc = (dmc1, sideEffect)
+onOutputCycleEnd :: DMC -> InterruptStatus -> (DMC, InterruptStatus)
+onOutputCycleEnd dmc interr = (dmc1, interr')
   where
     dmc0 = dmc{remainingBits = 8}
     dmc1 = case sampleBuffer dmc0 of
         Nothing -> dmc0{silentFlag = True}
         Just b -> dmc0{shiftRegister = b, sampleBuffer = Nothing}
-    sideEffect = setFlag' DMCDMA (isNothing (sampleBuffer dmc1) && sampleBytesRemaining dmc1 > 0) mempty
+    interr' =
+        if isNothing (sampleBuffer dmc1) && sampleBytesRemaining dmc1 > 0
+            then interr{irq = Just DMC}
+            else interr
 
 -- | Loads the byte into the sample buffer and shift the sample buffer-related values
-loadSampleBuffer :: Byte -> DMC -> (DMC, CPUSideEffect)
-loadSampleBuffer byte dmc =
+loadSampleBuffer :: Byte -> DMC -> InterruptStatus -> (DMC, InterruptStatus)
+loadSampleBuffer byte dmc s =
     let
         newSampleBufferAddr = let addr = sampleBufferAddr dmc + 1 in if addr >= 0xffff then addr - 0x8000 else addr
         newRemainingLength = max 0 (sampleBytesRemaining dmc - 1)
@@ -127,8 +135,8 @@ loadSampleBuffer byte dmc =
                 , shouldClock = newRemainingLength > 0
                 }
         shouldRestartSample = newRemainingLength == 0 && loopFlag dmc
-        shouldIRQ = newRemainingLength == 0 && irqEnabledFlag dmc
+        shouldIRQ = newRemainingLength == 0 && interruptFlag dmc
      in
         if shouldRestartSample
-            then (restartSample dmc1, mempty)
-            else (dmc1, setFlag' IRQ shouldIRQ mempty)
+            then (restartSample dmc1, s)
+            else (dmc1, if shouldIRQ then s{irq = Just DMC} else s)

src/Nes/APU/Tick.hs

@@ -27,11 +27,10 @@ import Nes.APU.State.LengthCounter
 import Nes.APU.State.Noise
 import Nes.APU.State.Pulse
 import Nes.APU.State.Triangle
-import Nes.Bus.SideEffect
-import Nes.FlagRegister
+import Nes.Interrupt
 import Prelude hiding (cycle)
 
--- $use
+-- $semantic
 --     The APU being a part of the CPU, they both tick at the same time. However, some ticks are updated every other CPU cycles.
 --     Here the 'tick' function should be called every CPU tick, and pass as parameter whether the tick is on an even CPU cycle or not.
 --     Same goes for 'tickMany'.
@@ -50,7 +49,7 @@ tickOnce :: IsAPUCycle -> APU r ()
 tickOnce isAPUCycle = do
     -- Ticks
     tickDelayedWriteBuffer
-    modifyAPUStateWithSideEffect $ modifyDMC' tickDMC
+    modifyAPUStateWithInterrupt $ modifyDMC' tickDMC
     modifyAPUState $
         modifyTriangle tickTriangle
             . modifyNoise tickNoise
@@ -59,7 +58,6 @@ tickOnce isAPUCycle = do
             modifyPulse1 tickPulse
                 . modifyPulse2 tickPulse
         tickFrameCounter
-
     -- Mixing
     sample <- withAPUState getMixerOutput
     modifyFilterChain $ consume sample
@@ -96,14 +94,10 @@ tickDelayedWriteBuffer = do
     fc <- withAPUState frameCounter
     case delayedWriteSideEffectCycle fc of
         Nothing -> return ()
-        Just 0 -> do
-            seqMode <- withAPUState $ sequenceMode . frameCounter
+        Just 0 ->
             modifyAPUState $
                 modifyFrameCounter $
                     const fc{delayedWriteSideEffectCycle = Nothing, FC.sequenceStep = 0, cycles = 0}
-            when (seqMode == FiveStep) $ do
-                runQuarterFrameEvent
-                runHalfFrameEvent
         Just n ->
             modifyAPUState $
                 modifyFrameCounter $
@@ -123,6 +117,8 @@ tickFrameCounterFourStep = do
     inhibitFrameInterrupt <- withAPUState $ inhibitInterrupt . frameCounter
     when (step < 4) runQuarterFrameEvent
     when (step == 1 || step == 3) runHalfFrameEvent
+    when (step == 4) $ -- Flag should be cleared when going from put to get
+        setFrameInterruptFlag False
     when (step == 3 && not inhibitFrameInterrupt) $
         setFrameInterruptFlag True
 
@@ -153,7 +149,7 @@ runHalfFrameEvent = modifyAPUState $ \st ->
 {-# INLINE setFrameInterruptFlag #-}
 setFrameInterruptFlag :: Bool -> APU r ()
 setFrameInterruptFlag b = do
-    setSideEffect $ setFlag IRQ
+    modifyInterruptStatus $ \s -> s{irq = Just FrameCounter}
     modifyAPUState $
         modifyFrameCounter $
             \fc -> fc{frameInterruptFlag = b}