APU

.gitignore

@@ -2,3 +2,4 @@
 *.log
 *.swp
 *.nes
+*.prof

app/Main.hs

@@ -1,7 +1,12 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
 module Main (main) where
 
 import Control.Monad
+import Data.IORef
+import qualified Data.Vector.Storable.Mutable as V
 import Events
+import Nes.APU.State.Filter.Constants
 import Nes.Bus
 import Nes.Bus.Monad (runBusM)
 import Nes.CPU.Interpreter
@@ -15,6 +20,12 @@ import SDL.Internal.Types
 import qualified SDL.Raw as Raw
 import System.Environment
 
+vectorSize :: Int
+vectorSize = 4 * sampleCount
+
+sampleCount :: Int
+sampleCount = 1024
+
 main :: IO ()
 main = do
     romPath <- do
@@ -25,7 +36,10 @@ main = do
     rom <- do
         res <- fromFile romPath
         either fail return res
+    vectorCursor <- newIORef 0
+    sampleVector <- V.new vectorSize
     initializeAll
+
     let windowConfig =
             defaultWindow
                 { windowInitialSize =
@@ -34,23 +48,48 @@ main = do
                         (240 * 3)
                 , windowPosition = Centered
                 }
+    (device, _) <-
+        openAudioDevice
+            OpenDeviceSpec
+                { SDL.openDeviceFreq = Mandate $ floor defaultOutputRate
+                , SDL.openDeviceFormat = Mandate FloatingLEAudio
+                , SDL.openDeviceChannels = Mandate Mono
+                , SDL.openDeviceSamples = fromIntegral sampleCount
+                , SDL.openDeviceCallback = audioCallback sampleVector vectorCursor
+                , SDL.openDeviceUsage = ForPlayback
+                , SDL.openDeviceName = Nothing
+                }
     window <- createWindow "FuNes" windowConfig
     renderer@(Renderer rendererPtr) <-
         createRenderer
             window
             (-1)
             defaultRenderer
-    _ <- setHintWithPriority NormalPriority HintRenderVSync DisableVSync
+    -- _ <- setHintWithPriority NormalPriority HintRenderVSync DisableVSync
     _ <- Raw.renderSetScale rendererPtr 3 3
     texture <- createTexture renderer RGB24 TextureAccessTarget (V2 256 240)
+    setAudioDevicePlaybackState device Play
     frame <- newFrameState
-    bus <- newBus rom (onDrawFrame frame texture renderer) tickCallback
+    bus <-
+        newBus
+            rom
+            (onDrawFrame frame texture renderer)
+            (sampleCallback sampleVector vectorCursor)
+            tickCallback
     void $ runProgram bus (pure ())
+    closeAudioDevice device
     destroyRenderer renderer
 
 tickCallback :: Double -> Int -> IO (Double, Int)
 tickCallback lastSleepTime_ ticks_ = return (lastSleepTime_, ticks_)
 
+sampleCallback :: V.IOVector Float -> IORef Int -> Float -> IO ()
+sampleCallback vec cursorRef sample = do
+    cursor <- readIORef cursorRef
+    when (cursor < vectorSize) $ do
+        V.write vec cursor sample
+        writeIORef cursorRef (cursor + 1)
+
 --   !currentTime <- getCPUTimeUs
 --   let !totalTickDurationUs = tickDurationUs * fromIntegral ticks_
 --       !deltaTimeUs = currentTime - lastSleepTime
@@ -76,6 +115,25 @@ tickCallback lastSleepTime_ ticks_ = return (lastSleepTime_, ticks_)
 --   -- Frequency in Hz
 --   cpuFrequency = 1.789773 * 1000000
 
+audioCallback :: V.IOVector Float -> IORef Int -> AudioFormat sampleType -> V.IOVector sampleType -> IO ()
+audioCallback samples cursorRef fmt buffer = case fmt of
+    FloatingLEAudio -> do
+        cursor <- readIORef cursorRef
+        let bufferLen = V.length buffer
+            nToCopy = min bufferLen cursor
+        when (cursor < bufferLen) $ do
+            V.set buffer 0
+        V.copy (V.slice 0 nToCopy buffer) (V.slice 0 nToCopy samples)
+        -- If more samples are ready
+        if cursor > bufferLen
+            then do
+                let toShift = cursor - bufferLen
+                V.unsafeCopy (V.slice 0 toShift samples) (V.slice (cursor - 1) toShift samples)
+                writeIORef cursorRef toShift
+            else
+                writeIORef cursorRef 0
+    _ -> error "Unsupported audio format"
+
 onDrawFrame :: FrameState -> Texture -> Renderer -> Bus -> IO Bus
 onDrawFrame frame texture renderer bus = do
     bs <- runRender (render bus R.>> toSDL2ByteString) frame

examples/Snake.hs

@@ -48,7 +48,7 @@ main = do
     texture <- createTexture renderer RGB24 TextureAccessTarget (V2 32 32)
     frame <- newArray @IOUArray (0, frameSize) (0 :: Word8)
     let cpuState = newCPUState{programCounter = programOffset}
-    bus <- newBus unsafeEmptyRom pure (\a b -> pure (a, b))
+    bus <- newBus unsafeEmptyRom pure (\_ -> pure ()) (\a b -> pure (a, b))
     loadProgramToMemory gameCode bus
     _ <- runProgram' cpuState bus (callback frame texture renderer)
     destroyRenderer renderer

funes.cabal

@@ -24,9 +24,34 @@ source-repository head
 
 library
   exposed-modules:
+      Nes.APU.BusInterface
+      Nes.APU.BusInterface.DMC
+      Nes.APU.BusInterface.FrameCounter
+      Nes.APU.BusInterface.Noise
+      Nes.APU.BusInterface.Pulse
+      Nes.APU.BusInterface.Status
+      Nes.APU.BusInterface.Triangle
+      Nes.APU.Mixer
+      Nes.APU.Monad
+      Nes.APU.State
+      Nes.APU.State.DMC
+      Nes.APU.State.Envelope
+      Nes.APU.State.Filter.Chain
+      Nes.APU.State.Filter.Class
+      Nes.APU.State.Filter.Constants
+      Nes.APU.State.Filter.Fir
+      Nes.APU.State.Filter.Iir
+      Nes.APU.State.Filter.Sampled
+      Nes.APU.State.FrameCounter
+      Nes.APU.State.LengthCounter
+      Nes.APU.State.Noise
+      Nes.APU.State.Pulse
+      Nes.APU.State.Triangle
+      Nes.APU.Tick
       Nes.Bus
       Nes.Bus.Constants
       Nes.Bus.Monad
+      Nes.Bus.SideEffect
       Nes.Controller
       Nes.CPU.Instructions.Access
       Nes.CPU.Instructions.Addressing
@@ -69,6 +94,7 @@ library
   hs-source-dirs:
       src
   default-extensions:
+      Strict
       BinaryLiterals
       LambdaCase
       GeneralizedNewtypeDeriving
@@ -79,7 +105,7 @@ library
       DeriveFunctor
       DataKinds
       QualifiedDo
-  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O2
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O3
   build-depends:
       array
     , base >=4.7 && <5
@@ -98,6 +124,7 @@ executable fake-snake
   hs-source-dirs:
       examples
   default-extensions:
+      Strict
       BinaryLiterals
       LambdaCase
       GeneralizedNewtypeDeriving
@@ -108,7 +135,7 @@ executable fake-snake
       DeriveFunctor
       DataKinds
       QualifiedDo
-  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O2 -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O3 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       array
     , base >=4.7 && <5
@@ -131,6 +158,7 @@ executable funes-exe
   hs-source-dirs:
       app
   default-extensions:
+      Strict
       BinaryLiterals
       LambdaCase
       GeneralizedNewtypeDeriving
@@ -141,7 +169,7 @@ executable funes-exe
       DeriveFunctor
       DataKinds
       QualifiedDo
-  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O2 -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O3 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       array
     , base >=4.7 && <5
@@ -163,6 +191,7 @@ test-suite nestest
   hs-source-dirs:
       test/nestest
   default-extensions:
+      Strict
       BinaryLiterals
       LambdaCase
       GeneralizedNewtypeDeriving
@@ -173,7 +202,7 @@ test-suite nestest
       DeriveFunctor
       DataKinds
       QualifiedDo
-  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O2 -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O3 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       array
     , base >=4.7 && <5
@@ -210,6 +239,7 @@ test-suite unit
   hs-source-dirs:
       test/unit
   default-extensions:
+      Strict
       BinaryLiterals
       LambdaCase
       GeneralizedNewtypeDeriving
@@ -220,7 +250,7 @@ test-suite unit
       DeriveFunctor
       DataKinds
       QualifiedDo
-  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O2 -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O3 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       array
     , base >=4.7 && <5

package.yaml

@@ -19,6 +19,7 @@ dependencies:
   - vector
 
 default-extensions:
+  - Strict
   - BinaryLiterals
   - LambdaCase
   - GeneralizedNewtypeDeriving
@@ -40,7 +41,7 @@ ghc-options:
   - -Wmissing-home-modules
   - -Wpartial-fields
   - -Wredundant-constraints
-  - -O2
+  - -O3
 
 library:
   source-dirs: src

src/Nes/APU/BusInterface.hs

@@ -0,0 +1,53 @@
+module Nes.APU.BusInterface (
+    writeToAPU,
+    readFromAPU,
+) where
+
+import Nes.APU.BusInterface.DMC
+import Nes.APU.BusInterface.FrameCounter
+import Nes.APU.BusInterface.Noise
+import Nes.APU.BusInterface.Pulse
+import Nes.APU.BusInterface.Status
+import Nes.APU.BusInterface.Triangle
+import Nes.APU.Monad
+import Nes.Memory (Addr, Byte (..))
+
+{-# INLINE writeToAPU #-}
+writeToAPU :: Addr -> Byte -> APU r ()
+writeToAPU addr = case addr of
+    -- Pulse 1
+    0x4000 -> write4000
+    0x4001 -> write4001
+    0x4002 -> write4002
+    0x4003 -> write4003
+    -- Pulse 2
+    0x4004 -> write4004
+    0x4005 -> write4005
+    0x4006 -> write4006
+    0x4007 -> write4007
+    -- Triangle
+    0x4008 -> write4008
+    0x400A -> write400A
+    0x400B -> write400B
+    -- Noise
+    0x400C -> write400C
+    0x400E -> write400E
+    0x400F -> write400F
+    -- DMC
+    0x4010 -> write4010
+    0x4011 -> write4011
+    0x4012 -> write4012
+    0x4013 -> write4013
+    -- Status
+    0x4015 -> write4015
+    -- Frame Counter
+    0x4017 -> write4017
+    _ -> const (return ())
+
+{-# INLINE readFromAPU #-}
+readFromAPU :: Addr -> APU r (Maybe Byte)
+readFromAPU = \case
+    -- TODO Not open bus
+    -- TODO Bit 5 is open bus.
+    0x4015 -> Just <$> read4015
+    _ -> return Nothing

src/Nes/APU/BusInterface/DMC.hs

@@ -0,0 +1,40 @@
+module Nes.APU.BusInterface.DMC (write4010, write4011, write4012, write4013) where
+
+import Data.Bits
+import Nes.APU.Monad
+import Nes.APU.State (modifyDMC)
+import Nes.APU.State.DMC
+import Nes.Memory
+
+{-# INLINE write4010 #-}
+write4010 :: Byte -> APU r ()
+write4010 byte = do
+    let irq = byte `testBit` 7
+        loop = byte `testBit` 6
+        rateIdx = byteToInt $ byte .&. 0b1111
+        rate = getPeriodValue rateIdx
+    modifyAPUState $ modifyDMC $ \dmc ->
+        dmc
+            { irqEnabledFlag = irq
+            , loopFlag = loop
+            , period = rate
+            }
+
+{-# INLINE write4011 #-}
+write4011 :: Byte -> APU r ()
+write4011 byte = do
+    let directLoad = byteToInt $ byte .&. 0b1111111
+    -- TODO If the timer is outputting a clock at the same time, the output level is occasionally not changed properly.
+    modifyAPUState $ modifyDMC $ \dmc -> dmc{outputLevel = directLoad}
+
+{-# INLINE write4012 #-}
+write4012 :: Byte -> APU r ()
+write4012 byte = do
+    let sampleAddr = 0xC000 + (byteToAddr byte * 64)
+    modifyAPUState $ modifyDMC $ \dmc -> dmc{sampleOgAddr = sampleAddr}
+
+{-# INLINE write4013 #-}
+write4013 :: Byte -> APU r ()
+write4013 byte = do
+    let sampleLength = (byteToInt byte * 16) + 1
+    modifyAPUState $ modifyDMC $ \dmc -> dmc{sampleOgLength = sampleLength}

src/Nes/APU/BusInterface/FrameCounter.hs

@@ -0,0 +1,24 @@
+module Nes.APU.BusInterface.FrameCounter (write4017) where
+
+import Control.Monad
+import Data.Bits
+import Nes.APU.Monad
+import Nes.APU.State
+import Nes.APU.State.FrameCounter
+import Nes.APU.Tick
+import Nes.Memory
+
+-- | Callback when a byte is written to 0x4017 through the Bus
+{-# INLINE write4017 #-}
+write4017 :: Byte -> APU r ()
+write4017 byte = do
+    c <- withAPUState Nes.APU.State.cycle
+    let seqMode = sequenceModeFromBool $ byte `testBit` 7
+        inhibit = byte `testBit` 6
+        delay = if even c then 4 else 3
+    modifyAPUState $
+        modifyFrameCounter $
+            \fc -> fc{sequenceMode = seqMode, inhibitInterrupt = inhibit, delayedWriteSideEffectCycle = Just delay}
+    -- If the mode flag is set, then both "quarter frame" and "half frame" signals are also generated
+    when inhibit $ do
+        setFrameInterruptFlag False