APU: Run filters in another thread

app/Main.hs

@@ -7,6 +7,7 @@ import Data.IORef
 import qualified Data.Vector.Storable.Mutable as V
 import Events
 import Nes.APU.State.Filter.Constants
+import Nes.APU.State.Filter.Thread
 import Nes.Bus
 import Nes.Bus.Monad (runBusM)
 import Nes.CPU.Interpreter
@@ -69,15 +70,18 @@ main = do
     _ <- Raw.renderSetScale rendererPtr 3 3
     texture <- createTexture renderer RGB24 TextureAccessTarget (V2 256 240)
     setAudioDevicePlaybackState device Play
+    filterThread <- newFilterThread
     frame <- newFrameState
     bus <-
         newBus
             rom
             (onDrawFrame frame texture renderer)
             (sampleCallback sampleVector vectorCursor)
             tickCallback
+            filterThread
     void $ runProgram bus (pure ())
     closeAudioDevice device
+    killFilterThread filterThread
     destroyRenderer renderer
 
 tickCallback :: Double -> Int -> IO (Double, Int)
@@ -90,31 +94,6 @@ sampleCallback vec cursorRef sample = do
         V.write vec cursor sample
         writeIORef cursorRef (cursor + 1)
 
---   !currentTime <- getCPUTimeUs
---   let !totalTickDurationUs = tickDurationUs * fromIntegral ticks_
---       !deltaTimeUs = currentTime - lastSleepTime
---       !sleepUs = totalTickDurationUs - deltaTimeUs
---   if ticks_ < 100
---       then return (lastSleepTime, ticks_)
---       else
---           if sleepUs > 500
---               then do
---                   let !intSleepUs = floor sleepUs
---                       !remainingSleepUs = sleepUs - fromIntegral intSleepUs
---                       !residualTicks = floor $ remainingSleepUs / tickDurationUs
---                   -- threadDelay intSleepUs
---                   return (currentTime, residualTicks)
---               else
---                   if sleepUs < 0
---                       then do
---                           return (currentTime, 0)
---                       else do
---                           return (lastSleepTime, ticks_)
--- where
---   tickDurationUs = (1000000 / cpuFrequency) :: Double
---   -- 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
@@ -125,7 +104,7 @@ audioCallback samples cursorRef fmt buffer = case fmt of
             V.set buffer 0
         V.copy (V.slice 0 nToCopy buffer) (V.slice 0 nToCopy samples)
         -- If more samples are ready
-        if cursor > bufferLen
+        if cursor >= bufferLen
             then do
                 let toShift = cursor - bufferLen
                 V.unsafeCopy (V.slice 0 toShift samples) (V.slice (cursor - 1) toShift samples)
@@ -142,6 +121,31 @@ onDrawFrame frame texture renderer bus = do
     present renderer
     snd <$> runBusM bus handleEvents
 
+--   !currentTime <- getCPUTimeUs
+--   let !totalTickDurationUs = tickDurationUs * fromIntegral ticks_
+--       !deltaTimeUs = currentTime - lastSleepTime
+--       !sleepUs = totalTickDurationUs - deltaTimeUs
+--   if ticks_ < 100
+--       then return (lastSleepTime, ticks_)
+--       else
+--           if sleepUs > 500
+--               then do
+--                   let !intSleepUs = floor sleepUs
+--                       !remainingSleepUs = sleepUs - fromIntegral intSleepUs
+--                       !residualTicks = floor $ remainingSleepUs / tickDurationUs
+--                   -- threadDelay intSleepUs
+--                   return (currentTime, residualTicks)
+--               else
+--                   if sleepUs < 0
+--                       then do
+--                           return (currentTime, 0)
+--                       else do
+--                           return (lastSleepTime, ticks_)
+-- where
+--   tickDurationUs = (1000000 / cpuFrequency) :: Double
+--   -- Frequency in Hz
+--   cpuFrequency = 1.789773 * 1000000
+
 -- {-# INLINE getCPUTimeUs #-}
 -- getCPUTimeUs :: IO Double
 -- getCPUTimeUs = (/ 1000000) . fromIntegral <$> getCPUTime

examples/Snake.hs

@@ -11,6 +11,7 @@ import Data.ByteString.Internal (create)
 import Data.Functor (($>))
 import Data.Word (Word8)
 import GHC.Storable (writeWord8OffPtr)
+import Nes.APU.State.Filter.Thread
 import Nes.Bus
 import Nes.Bus.Monad ()
 import Nes.CPU.Interpreter
@@ -48,7 +49,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 (\_ -> pure ()) (\a b -> pure (a, b))
+    bus <- newBus unsafeEmptyRom pure (\_ -> pure ()) (\a b -> pure (a, b)) newNoopFilterThread
     loadProgramToMemory gameCode bus
     _ <- runProgram' cpuState bus (callback frame texture renderer)
     destroyRenderer renderer

funes.cabal

@@ -42,6 +42,7 @@ library
       Nes.APU.State.Filter.Fir
       Nes.APU.State.Filter.Iir
       Nes.APU.State.Filter.Sampled
+      Nes.APU.State.Filter.Thread
       Nes.APU.State.FrameCounter
       Nes.APU.State.LengthCounter
       Nes.APU.State.Noise
@@ -106,7 +107,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 -O3
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -O2
   build-depends:
       array
     , base >=4.7 && <5
@@ -136,7 +137,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 -O3 -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 -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       array
     , base >=4.7 && <5
@@ -170,7 +171,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 -O3 -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 -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       array
     , base >=4.7 && <5
@@ -203,7 +204,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 -O3 -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 -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       array
     , base >=4.7 && <5
@@ -251,7 +252,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 -O3 -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 -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       array
     , base >=4.7 && <5

package.yaml

@@ -41,7 +41,7 @@ ghc-options:
   - -Wmissing-home-modules
   - -Wpartial-fields
   - -Wredundant-constraints
-  - -O3
+  - -O2
 
 library:
   source-dirs: src

src/Nes/APU/Monad.hs

@@ -4,14 +4,12 @@ module Nes.APU.Monad (
     modifyAPUState,
     modifyAPUStateWithInterrupt,
     withAPUState,
-    modifyFilterChain,
     modifyInterruptStatus,
     withInterruptStatus,
 ) where
 
 import Control.Monad.IO.Class
 import Nes.APU.State
-import Nes.APU.State.Filter.Chain (FilterChain)
 import Nes.Interrupt
 
 newtype APU r a = MkAPU
@@ -57,11 +55,6 @@ modifyAPUStateWithInterrupt f = MkAPU $ \(!st) !interr cont ->
 withAPUState :: (APUState -> a) -> APU r a
 withAPUState f = MkAPU $ \(!st) !interr cont -> cont st interr (f st)
 
-{-# INLINE modifyFilterChain #-}
-modifyFilterChain :: (FilterChain -> FilterChain) -> APU r ()
-modifyFilterChain f = MkAPU $ \(!st) !interr cont ->
-    cont st{filterChain = f $ filterChain st} interr ()
-
 {-# INLINE modifyInterruptStatus #-}
 modifyInterruptStatus :: (InterruptStatus -> InterruptStatus) -> APU r ()
 modifyInterruptStatus f = MkAPU $ \(!st) !interrupt cont -> cont st (f interrupt) ()

src/Nes/APU/State.hs

@@ -16,8 +16,8 @@ module Nes.APU.State (
 ) where
 
 import Nes.APU.State.DMC
-import Nes.APU.State.Filter.Chain
 import Nes.APU.State.Filter.Constants (defaultOutputRate)
+import Nes.APU.State.Filter.Thread (FilterThread)
 import Nes.APU.State.FrameCounter
 import Nes.APU.State.Noise
 import Nes.APU.State.Pulse
@@ -34,16 +34,16 @@ data APUState = MkAPUState
     , dmc :: !DMC
     , cycle :: {-# UNPACK #-} !Int
     -- ^ Number of CPU cycles since the start
-    , filterChain :: !FilterChain
+    , filterThread :: !FilterThread
     , sampleTimer :: {-# UNPACK #-} !Float
     -- ^ The number of CPU cycles since the last call to 'pushSampleCallback'
     , samplePeriod :: {-# UNPACK #-} !Float
     -- ^ The number of CPU cycles between each call to 'pushSampleCallback'
     , pushSampleCallback :: Float -> IO ()
     }
 
-newAPUState :: (Float -> IO ()) -> APUState
-newAPUState pushSampleCallback = MkAPUState{..}
+newAPUState :: (Float -> IO ()) -> FilterThread -> APUState
+newAPUState pushSampleCallback filterThread = MkAPUState{..}
   where
     frameCounter = newFrameCounter
     cycle = 0
@@ -52,7 +52,6 @@ newAPUState pushSampleCallback = MkAPUState{..}
     triangle = newTriangle
     noise = newNoise
     dmc = newDMC
-    filterChain = newFilterChain defaultOutputRate
     samplePeriod = (21477272 / 12) / defaultOutputRate
     sampleTimer = samplePeriod
 

src/Nes/APU/State/Filter/Chain.hs

@@ -1,7 +1,11 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Nes.APU.State.Filter.Chain (FilterChain (..), newFilterChain) where
 
+import Control.Monad
+import qualified Data.Vector.Mutable as V
 import Nes.APU.State.Filter.Class
 import Nes.APU.State.Filter.Constants
 import Nes.APU.State.Filter.Fir
@@ -10,72 +14,68 @@ import Nes.APU.State.Filter.Sampled
 import Prelude hiding (filter)
 
 data FilterChain = MkFC
-    { filters :: ![SampledFilter]
+    { filters :: !(V.IOVector SampledFilter)
     , dt :: {-# UNPACK #-} !Float
     }
 
-newFilterChain :: OutputRate -> FilterChain
-newFilterChain outputRate = MkFC{..}
+newFilterChain :: OutputRate -> IO FilterChain
+newFilterChain outputRate = do
+    filtersList <- do
+        _firFilter <- lowPassFirFilter intermediateSampleRate (outputRate * 0.45) 160
+        return
+            [ newSampledFilter (Left identityIirFilter) 1.0
+            , newSampledFilter (Left $ lowPassIirFilter clockRate intermediateCutoff) clockRate
+            , newSampledFilter (Left $ highPassIirFilter intermediateSampleRate 90) intermediateSampleRate
+            , newSampledFilter (Left $ highPassIirFilter intermediateSampleRate 440) intermediateSampleRate
+            , newSampledFilter (Left $ lowPassIirFilter intermediateSampleRate 14000) intermediateSampleRate
+            -- , newSampledFilter (Right firFilter) intermediateSampleRate
+            ]
+    filters <- V.new $ length filtersList
+    forM_ (zip [0 ..] filtersList) $ uncurry (V.write filters)
+    return MkFC{..}
   where
     clockRate = 21477272 / 12
     intermediateSampleRate = outputRate * 2 + (pi / 32)
     intermediateCutoff = outputRate * 0.4
     dt = 1 / clockRate
-    filters =
-        [ newSampledFilter (Left identityIirFilter) 1.0
-        , newSampledFilter (Left $ lowPassIirFilter clockRate intermediateCutoff) clockRate
-        , newSampledFilter (Left $ highPassIirFilter intermediateSampleRate 90) intermediateSampleRate
-        , newSampledFilter (Left $ highPassIirFilter intermediateSampleRate 440) intermediateSampleRate
-        , newSampledFilter (Left $ lowPassIirFilter intermediateSampleRate 14000) intermediateSampleRate
-        , newSampledFilter (Right $ lowPassFirFilter intermediateSampleRate (outputRate * 0.45) 160) intermediateSampleRate
-        ]
 
-instance Filter FilterChain where
+instance Filter IO FilterChain where
     consume = filterChainConsumeSample
     output = filterChainOutput
 
-filterChainConsumeSample :: Sample -> FilterChain -> FilterChain
-filterChainConsumeSample sample fc =
-    let
-        fc1 = modifyFilterAtIndex 0 (consume sample) fc
-        updatedFilters = go (filters fc1) (dt fc1)
-     in
-        fc1{filters = updatedFilters}
-  where
-    go :: [SampledFilter] -> Float -> [SampledFilter]
-    go [] _ = []
-    go [a] _ = [a]
-    go (prev : curr : rest) dt =
-        let
-            newCurr = filterChainConsumeIteration prev curr dt
-         in
-            prev : go (newCurr : rest) dt
+filterChainConsumeSample :: Sample -> FilterChain -> IO FilterChain
+filterChainConsumeSample sample fc = do
+    V.modifyM (filters fc) (consume sample) 0
+    firstFilter <- V.read (filters fc) 0
+    _ <-
+        V.ifoldM
+            ( \prev currIdx curr -> do
+                newCurr <- filterChainConsumeIteration prev (dt fc) curr
+                V.write (filters fc) currIdx newCurr
+                return newCurr
+            )
+            firstFilter
+            (filters fc)
+    return fc
 
-filterChainConsumeIteration :: SampledFilter -> SampledFilter -> Float -> SampledFilter
-filterChainConsumeIteration prev current dt =
+filterChainConsumeIteration :: SampledFilter -> Float -> SampledFilter -> IO SampledFilter
+filterChainConsumeIteration prev dt current =
     if periodCounter current >= samplePeriod current
-        then
+        then do
             let
                 newPeriodCounter = periodCounter current - samplePeriod current
-                previousOutput = output $ filter prev
-                newCurrent = consume previousOutput $ current{periodCounter = newPeriodCounter}
-             in
-                filterChainConsumeIteration
-                    prev
-                    newCurrent
-                    dt
+            previousOutput <- output $ filter prev
+            newCurrent <- consume previousOutput $ current{periodCounter = newPeriodCounter}
+            filterChainConsumeIteration
+                prev
+                dt
+                newCurrent
         else
             let newPeriodCounter = periodCounter current + dt
-             in current{periodCounter = newPeriodCounter}
-
-{-# INLINE modifyFilterAtIndex #-}
-modifyFilterAtIndex :: Int -> (SampledFilter -> SampledFilter) -> FilterChain -> FilterChain
-modifyFilterAtIndex idx f fc = case splitAt idx $ filters fc of
-    (_, []) -> fc
-    (left, item : right) -> fc{filters = left ++ (f item : right)}
+             in return $ current{periodCounter = newPeriodCounter}
 
 {-# INLINE filterChainOutput #-}
-filterChainOutput :: FilterChain -> Sample
-filterChainOutput fc = case filters fc of
-    [] -> 0
-    l -> either output output . filter $ last l
+filterChainOutput :: FilterChain -> IO Sample
+filterChainOutput fc = case V.length $ filters fc of
+    0 -> return 0
+    l -> either (output @IO) (output @IO) . filter =<< V.read (filters fc) (l - 1)

src/Nes/APU/State/Filter/Class.hs

@@ -1,11 +1,17 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
 module Nes.APU.State.Filter.Class (Filter (..)) where
 
 import Nes.APU.State.Filter.Constants
 
-class Filter a where
-    consume :: Sample -> a -> a
-    output :: a -> Sample
+class Filter m a where
+    consume :: Sample -> a -> m a
+    output :: a -> m Sample
 
-instance (Filter a, Filter b) => Filter (Either a b) where
-    consume sample = either (Left . consume sample) (Right . consume sample)
-    output = either output output
+instance (Monad m, Filter m a, Filter m b) => Filter m (Either a b) where
+    consume sample = either (fmap Left . consume sample) (fmap Right . consume sample)
+    output = either (output @m) (output @m)