From f433c5af6f000b69f045517af3b90cbef8f96ef4 Mon Sep 17 00:00:00 2001 From: Arthur Jamet Date: Mon, 17 Nov 2025 13:45:13 +0000 Subject: [PATCH 1/3] Use thread for APU filter --- app/Main.hs | 4 +++ examples/Snake.hs | 3 +- funes.cabal | 3 +- package.yaml | 2 +- src/Nes/APU/Monad.hs | 7 ----- src/Nes/APU/State.hs | 9 +++--- src/Nes/APU/State/Filter/Thread.hs | 49 ++++++++++++++++++++++++++++++ src/Nes/APU/Tick.hs | 6 ++-- src/Nes/Bus.hs | 7 +++-- test/nestest/Spec.hs | 3 +- test/unit/Internal.hs | 3 +- 11 files changed, 73 insertions(+), 23 deletions(-) create mode 100644 src/Nes/APU/State/Filter/Thread.hs diff --git a/app/Main.hs b/app/Main.hs index b15c07c..e7660ed 100644 --- a/app/Main.hs +++ b/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,6 +70,7 @@ main = do _ <- Raw.renderSetScale rendererPtr 3 3 texture <- createTexture renderer RGB24 TextureAccessTarget (V2 256 240) setAudioDevicePlaybackState device Play + filterThread <- newFilterThread frame <- newFrameState bus <- newBus @@ -76,8 +78,10 @@ main = do (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) diff --git a/examples/Snake.hs b/examples/Snake.hs index de50a51..873bebe 100644 --- a/examples/Snake.hs +++ b/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 diff --git a/funes.cabal b/funes.cabal index df09ce2..72868b9 100644 --- a/funes.cabal +++ b/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 @@ -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 -O3 -threaded -rtsopts -with-rtsopts=-N3 build-depends: array , base >=4.7 && <5 diff --git a/package.yaml b/package.yaml index 80ae1ac..0ce9148 100644 --- a/package.yaml +++ b/package.yaml @@ -53,7 +53,7 @@ executables: ghc-options: - -threaded - -rtsopts - - -with-rtsopts=-N + - -with-rtsopts=-N3 dependencies: - funes - sdl2 diff --git a/src/Nes/APU/Monad.hs b/src/Nes/APU/Monad.hs index 4d18305..29214b5 100644 --- a/src/Nes/APU/Monad.hs +++ b/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) () diff --git a/src/Nes/APU/State.hs b/src/Nes/APU/State.hs index 1d74f24..d9808b7 100644 --- a/src/Nes/APU/State.hs +++ b/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,7 +34,7 @@ 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 @@ -42,8 +42,8 @@ data APUState = MkAPUState , 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 diff --git a/src/Nes/APU/State/Filter/Thread.hs b/src/Nes/APU/State/Filter/Thread.hs new file mode 100644 index 0000000..59489be --- /dev/null +++ b/src/Nes/APU/State/Filter/Thread.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoStrict #-} + +module Nes.APU.State.Filter.Thread where + +import Control.Concurrent +import Control.Monad +import Data.IORef +import Data.Maybe +import Nes.APU.State.Filter.Chain +import Nes.APU.State.Filter.Class +import Nes.APU.State.Filter.Constants + +data FilterThread = MkFT + { consumeSample :: Sample -> IO () + , outputSample :: !(IO Sample) + , threadId :: {-# UNPACK #-} !(Maybe ThreadId) + } + +-- | A FilterThread that does nothing and always returns 0 +newNoopFilterThread :: FilterThread +newNoopFilterThread = MkFT (const $ pure ()) (pure 0) Nothing + +-- | A FilterThread that spawns a process to run the filter chain in the backgroun +newFilterThread :: IO FilterThread +newFilterThread = do + filtersRef <- newIORef $ newFilterChain defaultOutputRate + inputVar <- newEmptyMVar + getInputVar <- newEmptyMVar + postOutputVar <- newEmptyMVar + threadId <- Just <$> forkIO (thread filtersRef inputVar getInputVar postOutputVar) + let consumeSample = putMVar inputVar + outputSample = putMVar getInputVar () >> takeMVar postOutputVar + return $ MkFT{..} + where + thread filterRef inV getV postV = do + needOutput <- isJust <$> tryTakeMVar getV + when needOutput $ do + filterOutput <- output <$> readIORef filterRef + postIsFull <- tryPutMVar postV filterOutput + when postIsFull $ return () -- NOTE Shouldn't happen + msample <- tryTakeMVar inV + case msample of + Nothing -> pure () + Just sample -> modifyIORef filterRef (consume sample) + thread filterRef inV getV postV + +killFilterThread :: FilterThread -> IO () +killFilterThread ft = maybe (pure ()) killThread $ threadId ft diff --git a/src/Nes/APU/Tick.hs b/src/Nes/APU/Tick.hs index a0e37d8..8a23b8d 100644 --- a/src/Nes/APU/Tick.hs +++ b/src/Nes/APU/Tick.hs @@ -20,7 +20,7 @@ import Nes.APU.State import qualified Nes.APU.State as S import Nes.APU.State.DMC import Nes.APU.State.Envelope -import Nes.APU.State.Filter.Class +import Nes.APU.State.Filter.Thread import Nes.APU.State.FrameCounter import qualified Nes.APU.State.FrameCounter as FC import Nes.APU.State.LengthCounter @@ -60,11 +60,11 @@ tickOnce isAPUCycle = do tickFrameCounter -- Mixing sample <- withAPUState getMixerOutput - modifyFilterChain $ consume sample + liftIO . (`consumeSample` sample) =<< withAPUState filterThread modifyAPUState $ \st -> st{sampleTimer = sampleTimer st - 1} sampleTimer' <- withAPUState sampleTimer when (sampleTimer' <= 1) $ do - filterOut <- withAPUState $ output . filterChain + filterOut <- liftIO . outputSample =<< withAPUState filterThread callback <- withAPUState pushSampleCallback liftIO $ callback filterOut modifyAPUState $ diff --git a/src/Nes/Bus.hs b/src/Nes/Bus.hs index c32918e..94cc6cf 100644 --- a/src/Nes/Bus.hs +++ b/src/Nes/Bus.hs @@ -14,6 +14,7 @@ module Nes.Bus ( ) where import Nes.APU.State (APUState, newAPUState) +import Nes.APU.State.Filter.Thread (FilterThread) import Nes.Bus.SideEffect (CPUSideEffect) import Nes.Controller import Nes.Internal @@ -52,8 +53,8 @@ data Bus = Bus , cpuInterrupt :: {-# UNPACK #-} !InterruptStatus } -newBus :: Rom -> (Bus -> IO Bus) -> (Float -> IO ()) -> (Double -> Int -> IO (Double, Int)) -> IO Bus -newBus rom_ onNewFrame_ pushSample_ tickCallback_ = do +newBus :: Rom -> (Bus -> IO Bus) -> (Float -> IO ()) -> (Double -> Int -> IO (Double, Int)) -> FilterThread -> IO Bus +newBus rom_ onNewFrame_ pushSample_ tickCallback_ filterThread = do fptr <- callocForeignPtr vramSize ppuPtrs <- newPPUPointers let ppuSt = newPPUState (mirroring rom_) @@ -70,7 +71,7 @@ newBus rom_ onNewFrame_ pushSample_ tickCallback_ = do ppuPtrs onNewFrame_ 0 - (newAPUState pushSample_) + (newAPUState pushSample_ filterThread) mempty (MkIS Nothing False) diff --git a/test/nestest/Spec.hs b/test/nestest/Spec.hs index a92bcec..ee0117f 100644 --- a/test/nestest/Spec.hs +++ b/test/nestest/Spec.hs @@ -14,6 +14,7 @@ import Data.Char (isAlphaNum) import Data.IORef (IORef, modifyIORef, newIORef, readIORef) import Data.Int import qualified Data.Map as Map +import Nes.APU.State.Filter.Thread import Nes.Bus (Bus (..), newBus) import Nes.Bus.Monad import Nes.CPU.Instructions.Addressing @@ -39,7 +40,7 @@ spec = it "Trace should match logfile" $ do rom <- do eitherRom <- fromFile "test/assets/rom.nes" either fail return eitherRom - bus <- newBus rom pure (\_ -> pure ()) (curry return) + bus <- newBus rom pure (\_ -> pure ()) (curry return) newNoopFilterThread traceRef <- newIORef (T [] 0) let st = newCPUState{programCounter = 0xc000} -- TODO why is the tick count set to 7 ? Reset? diff --git a/test/unit/Internal.hs b/test/unit/Internal.hs index 58a8a32..55cedb4 100644 --- a/test/unit/Internal.hs +++ b/test/unit/Internal.hs @@ -2,6 +2,7 @@ module Internal (withProgram, withState, withMemorySetup, withStateAndMemorySetu import Control.Monad import Data.Word +import Nes.APU.State.Filter.Thread import Nes.Bus import Nes.CPU.Interpreter (runProgram') import Nes.CPU.Monad (CPU (MkCPU)) @@ -21,7 +22,7 @@ withStateAndMemorySetup :: (CPUState -> Bus -> IO r') -> IO () withStateAndMemorySetup program st memSetup post = do - bus <- newBus unsafeEmptyRom pure (\_ -> pure ()) (\a b -> return (a, b)) + bus <- newBus unsafeEmptyRom pure (\_ -> pure ()) (\a b -> return (a, b)) newNoopFilterThread loadProgramToMemory program bus _ <- memSetup bus -- Not we do not read 0xfffc because it's out of the bus read From ea37bfce5023c7300f42234ca9e248a7f4ca7881 Mon Sep 17 00:00:00 2001 From: Arthur Jamet Date: Wed, 19 Nov 2025 12:57:47 +0000 Subject: [PATCH 2/3] tmp --- src/Nes/APU/State/Filter/Chain.hs | 3 ++- src/Nes/APU/State/Filter/Thread.hs | 27 ++++++++++++++------------- src/Nes/APU/Tick.hs | 4 ++-- src/Nes/Bus.hs | 3 --- src/Nes/Bus/Monad.hs | 8 ++++---- src/Nes/CPU/Monad.hs | 5 ----- 6 files changed, 22 insertions(+), 28 deletions(-) diff --git a/src/Nes/APU/State/Filter/Chain.hs b/src/Nes/APU/State/Filter/Chain.hs index efa729b..45062ce 100644 --- a/src/Nes/APU/State/Filter/Chain.hs +++ b/src/Nes/APU/State/Filter/Chain.hs @@ -2,6 +2,7 @@ module Nes.APU.State.Filter.Chain (FilterChain (..), newFilterChain) where +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,7 +11,7 @@ import Nes.APU.State.Filter.Sampled import Prelude hiding (filter) data FilterChain = MkFC - { filters :: ![SampledFilter] + { filters :: !(V.IOVector SampledFilter) , dt :: {-# UNPACK #-} !Float } diff --git a/src/Nes/APU/State/Filter/Thread.hs b/src/Nes/APU/State/Filter/Thread.hs index 59489be..6783428 100644 --- a/src/Nes/APU/State/Filter/Thread.hs +++ b/src/Nes/APU/State/Filter/Thread.hs @@ -1,5 +1,4 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoStrict #-} module Nes.APU.State.Filter.Thread where @@ -32,18 +31,20 @@ newFilterThread = do let consumeSample = putMVar inputVar outputSample = putMVar getInputVar () >> takeMVar postOutputVar return $ MkFT{..} - where - thread filterRef inV getV postV = do - needOutput <- isJust <$> tryTakeMVar getV - when needOutput $ do - filterOutput <- output <$> readIORef filterRef - postIsFull <- tryPutMVar postV filterOutput - when postIsFull $ return () -- NOTE Shouldn't happen - msample <- tryTakeMVar inV - case msample of - Nothing -> pure () - Just sample -> modifyIORef filterRef (consume sample) - thread filterRef inV getV postV + +thread :: IORef FilterChain -> MVar Sample -> MVar () -> MVar Sample -> IO () +thread filterRef inV getV postV = do + msample <- tryTakeMVar inV + case msample of + Nothing -> pure () + Just sample -> modifyIORef' filterRef (consume sample) + + needOutput <- isJust <$> tryTakeMVar getV + when needOutput $ do + filterOutput <- output <$> readIORef filterRef + postIsFull <- tryPutMVar postV filterOutput + when postIsFull $ return () -- NOTE Shouldn't happen + thread filterRef inV getV postV killFilterThread :: FilterThread -> IO () killFilterThread ft = maybe (pure ()) killThread $ threadId ft diff --git a/src/Nes/APU/Tick.hs b/src/Nes/APU/Tick.hs index 8a23b8d..bf40531 100644 --- a/src/Nes/APU/Tick.hs +++ b/src/Nes/APU/Tick.hs @@ -64,8 +64,8 @@ tickOnce isAPUCycle = do modifyAPUState $ \st -> st{sampleTimer = sampleTimer st - 1} sampleTimer' <- withAPUState sampleTimer when (sampleTimer' <= 1) $ do - filterOut <- liftIO . outputSample =<< withAPUState filterThread - callback <- withAPUState pushSampleCallback + !filterOut <- liftIO . outputSample =<< withAPUState filterThread + !callback <- withAPUState pushSampleCallback liftIO $ callback filterOut modifyAPUState $ \st -> st{sampleTimer = S.sampleTimer st + S.samplePeriod st} diff --git a/src/Nes/Bus.hs b/src/Nes/Bus.hs index 94cc6cf..69fbb4d 100644 --- a/src/Nes/Bus.hs +++ b/src/Nes/Bus.hs @@ -15,7 +15,6 @@ module Nes.Bus ( import Nes.APU.State (APUState, newAPUState) import Nes.APU.State.Filter.Thread (FilterThread) -import Nes.Bus.SideEffect (CPUSideEffect) import Nes.Controller import Nes.Internal import Nes.Interrupt @@ -49,7 +48,6 @@ data Bus = Bus , dataBus :: {-# UNPACK #-} !Byte -- ^ Last read/written byte , apuState :: !APUState - , cpuSideEffect :: {-# UNPACK #-} !CPUSideEffect , cpuInterrupt :: {-# UNPACK #-} !InterruptStatus } @@ -72,7 +70,6 @@ newBus rom_ onNewFrame_ pushSample_ tickCallback_ filterThread = do onNewFrame_ 0 (newAPUState pushSample_ filterThread) - mempty (MkIS Nothing False) modifyPPUState :: (PPUState -> PPUState) -> Bus -> Bus diff --git a/src/Nes/Bus/Monad.hs b/src/Nes/Bus/Monad.hs index d77c12d..00bafce 100644 --- a/src/Nes/Bus/Monad.hs +++ b/src/Nes/Bus/Monad.hs @@ -86,11 +86,11 @@ tick n = MkBusM $ \bus cont -> do let unsleptCycles_ = n + unsleptCycles bus (newLastSleepTime, newUnsleptCycles) <- cycleCallback bus (lastSleepTime bus) unsleptCycles_ - ((_isNewFrame, nmiBefore, nmiAfter), ppuSt) <- runPPU (ppuState bus) (ppuPointers bus) (cartridge bus) $ do + (isNewFrame, ppuSt) <- runPPU (ppuState bus) (ppuPointers bus) (cartridge bus) $ do before <- withPPUState nmiInterrupt - isNewFrame <- PPUM.tick (n * 3) + _ <- PPUM.tick (n * 3) after <- withPPUState nmiInterrupt - return (isNewFrame, before, after) + return (not before && after) ((), !apuSt, !interr) <- runAPU (apuState bus) (cpuInterrupt bus) $ APU.tick (odd (Nes.Bus.cycles bus)) n let bus' = bus @@ -101,7 +101,7 @@ tick n = MkBusM $ \bus cont -> do , lastSleepTime = newLastSleepTime , cpuInterrupt = interr } - if not nmiBefore && nmiAfter + if isNewFrame then onNewFrame bus' bus' >>= flip cont () else cont bus' () diff --git a/src/Nes/CPU/Monad.hs b/src/Nes/CPU/Monad.hs index 2d48dd1..10eb5ab 100644 --- a/src/Nes/CPU/Monad.hs +++ b/src/Nes/CPU/Monad.hs @@ -8,7 +8,6 @@ module Nes.CPU.Monad ( -- * Interracting with bus withBus, withBusState, - setSideEffect, -- * State modifyCPUState, @@ -48,7 +47,6 @@ import qualified Nes.Bus import Nes.Bus.Constants import Nes.Bus.Monad (BusM, modifyBus, runBusM) import qualified Nes.Bus.Monad as BusM -import Nes.Bus.SideEffect import Nes.CPU.State import Nes.FlagRegister import Nes.Interrupt @@ -100,9 +98,6 @@ withBusState f = MkCPU $ \st bus cont -> cont st bus (f bus) getCycles :: CPU r Integer getCycles = withBusState cycles -setSideEffect :: (CPUSideEffect -> CPUSideEffect) -> CPU r () -setSideEffect f = MkCPU $ \st bus cont -> cont st bus{cpuSideEffect = f $ cpuSideEffect bus} () - {-# INLINE getPC #-} -- | Returns the value of the Program counter as an Addr From 6734260d65c8a70e3605151bae1dce216898ab04 Mon Sep 17 00:00:00 2001 From: Arthur Jamet Date: Wed, 19 Nov 2025 15:05:35 +0000 Subject: [PATCH 3/3] APU: Filter: use mutable vectors --- app/Main.hs | 52 ++++++++-------- funes.cabal | 10 +-- package.yaml | 4 +- src/Nes/APU/State/Filter/Chain.hs | 95 ++++++++++++++--------------- src/Nes/APU/State/Filter/Class.hs | 18 ++++-- src/Nes/APU/State/Filter/Fir.hs | 78 ++++++++++++----------- src/Nes/APU/State/Filter/Iir.hs | 23 ++++--- src/Nes/APU/State/Filter/Sampled.hs | 17 ++++-- src/Nes/APU/State/Filter/Thread.hs | 21 +++---- 9 files changed, 166 insertions(+), 152 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index e7660ed..203fba7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -94,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 @@ -129,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) @@ -146,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 diff --git a/funes.cabal b/funes.cabal index 72868b9..51b8644 100644 --- a/funes.cabal +++ b/funes.cabal @@ -107,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 @@ -137,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 @@ -171,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=-N3 + 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 @@ -204,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 @@ -252,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 diff --git a/package.yaml b/package.yaml index 0ce9148..9ce03a5 100644 --- a/package.yaml +++ b/package.yaml @@ -41,7 +41,7 @@ ghc-options: - -Wmissing-home-modules - -Wpartial-fields - -Wredundant-constraints - - -O3 + - -O2 library: source-dirs: src @@ -53,7 +53,7 @@ executables: ghc-options: - -threaded - -rtsopts - - -with-rtsopts=-N3 + - -with-rtsopts=-N dependencies: - funes - sdl2 diff --git a/src/Nes/APU/State/Filter/Chain.hs b/src/Nes/APU/State/Filter/Chain.hs index 45062ce..5e9fa46 100644 --- a/src/Nes/APU/State/Filter/Chain.hs +++ b/src/Nes/APU/State/Filter/Chain.hs @@ -1,7 +1,10 @@ +{-# 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 @@ -15,68 +18,64 @@ data FilterChain = MkFC , 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) diff --git a/src/Nes/APU/State/Filter/Class.hs b/src/Nes/APU/State/Filter/Class.hs index 966fcf2..835b9c2 100644 --- a/src/Nes/APU/State/Filter/Class.hs +++ b/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) diff --git a/src/Nes/APU/State/Filter/Fir.hs b/src/Nes/APU/State/Filter/Fir.hs index 46c9c34..d375a3d 100644 --- a/src/Nes/APU/State/Filter/Fir.hs +++ b/src/Nes/APU/State/Filter/Fir.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoStrict #-} @@ -5,52 +7,50 @@ module Nes.APU.State.Filter.Fir (FirFilter (..), lowPassFirFilter) where -import Data.Functor ((<&>)) -import qualified Data.Vector.Unboxed as V +import Control.Monad.IO.Class +import qualified Data.Vector.Unboxed.Mutable as V import Nes.APU.State.Filter.Class import Nes.APU.State.Filter.Constants -- | Finite impulse response (FIR) filter data FirFilter = MkFirF - { kernel :: !(V.Vector Float) - , inputs :: !(V.Vector Float) + { kernel :: !(V.IOVector Float) + , inputs :: !(V.IOVector Float) , inputIndex :: {-# UNPACK #-} !Int } -instance Filter FirFilter where - output f = - let - kernelL = V.toList $ kernel f - inputsL = drop (inputIndex f) $ Prelude.cycle $ V.toList $ inputs f - in - sum (zipWith (*) kernelL inputsL) - consume sample f = - f - { inputIndex = newInputIndex - , inputs = newInputs - } +instance (MonadIO m) => Filter m FirFilter where + output MkFirF{..} = + liftIO $ + V.ifoldM' + ( \acc idx n -> do + n' <- V.read inputs ((idx + inputIndex) `mod` V.length inputs) + return $ acc + (n * n') + ) + 0 + kernel + consume sample f = liftIO $ do + V.write (inputs f) (inputIndex f) sample + return $ + f + { inputIndex = newInputIndex + } where newInputIndex = (inputIndex f + 1) `mod` V.length (inputs f) - newInputs = inputs f V.// [(inputIndex f, sample)] -lowPassFirFilter :: SampleRate -> Cutoff -> Int -> FirFilter -lowPassFirFilter sampleRate cutoff windowSize = MkFirF{..} - where - inputIndex = 0 - inputs = V.replicate (windowSize + 1) 0 - kernel = windowedSincKernel sampleRate cutoff windowSize +lowPassFirFilter :: SampleRate -> Cutoff -> Int -> IO FirFilter +lowPassFirFilter sampleRate cutoff windowSize = do + let inputIndex = 0 + kernel <- windowedSincKernel sampleRate cutoff (windowSize + 1) + inputs <- V.replicate (windowSize + 1) 0 + return MkFirF{..} -windowedSincKernel :: SampleRate -> Cutoff -> Int -> V.Vector Float -windowedSincKernel sampleRate cutoff windowSize = - let - fc = cutoff / sampleRate - kernelL :: [Float] - kernelL = - [0 .. windowSize] <&> \i -> - (sinc i fc windowSize) * blackmanWindow i windowSize - kernelV = V.fromList kernelL - in - normalise kernelV +windowedSincKernel :: SampleRate -> Cutoff -> Int -> IO (V.IOVector Float) +windowedSincKernel sampleRate cutoff windowSize = do + let fc = cutoff / sampleRate + kernelV <- V.generate windowSize $ \i -> (sinc i fc windowSize) * blackmanWindow i windowSize + normalise kernelV + return kernelV where blackmanWindow :: Int -> Int -> Float blackmanWindow idx winSize = @@ -73,12 +73,10 @@ windowedSincKernel sampleRate cutoff windowSize = if idx == (windowSize `div` 2) then tau * fc else (mySin (tau * fc * shiftedIndex)) / shiftedIndex - normalise :: V.Vector Float -> V.Vector Float - normalise vec = - let - vecSum = V.sum vec - in - V.map (/ vecSum) vec + normalise :: V.IOVector Float -> IO () + normalise vec = do + vecSum <- V.foldl' (+) 0 vec + V.imapM_ (\i a -> V.write vec i (a / vecSum)) vec -- | Faster implementation of the sin function, -- diff --git a/src/Nes/APU/State/Filter/Iir.hs b/src/Nes/APU/State/Filter/Iir.hs index d291b78..fda3cb4 100644 --- a/src/Nes/APU/State/Filter/Iir.hs +++ b/src/Nes/APU/State/Filter/Iir.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + module Nes.APU.State.Filter.Iir ( IirFilter (..), @@ -55,13 +60,15 @@ lowPassIirFilter sampleRate cutoff = period = 1 / sampleRate cutoffPeriod = 1 / (2 * pi * cutoff) -instance Filter IirFilter where +instance (Monad m) => Filter m IirFilter where {-# INLINE output #-} - output f = outputF f f + output f = return $ outputF f f {-# INLINE consume #-} - consume sample f = - f - { previousOutput = output f - , delta = sample - previousInput f - , previousInput = sample - } + consume sample f = do + prevOut <- output @m f + return $ + f + { previousOutput = prevOut + , delta = sample - previousInput f + , previousInput = sample + } diff --git a/src/Nes/APU/State/Filter/Sampled.hs b/src/Nes/APU/State/Filter/Sampled.hs index 02bb9e8..ea3d59d 100644 --- a/src/Nes/APU/State/Filter/Sampled.hs +++ b/src/Nes/APU/State/Filter/Sampled.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} module Nes.APU.State.Filter.Sampled (SampledFilter (..), newSampledFilter) where +import Control.Monad.IO.Class import Nes.APU.State.Filter.Class import Nes.APU.State.Filter.Constants import Nes.APU.State.Filter.Fir @@ -20,13 +23,15 @@ newSampledFilter filter sampleRate = MkSF{..} periodCounter = 1 samplePeriod = 1 / sampleRate -instance Filter SampledFilter where +instance (MonadIO m) => Filter m SampledFilter where consume = sampledFilterConsumeSample output sf = output $ filter sf {-# INLINE sampledFilterConsumeSample #-} -sampledFilterConsumeSample :: Sample -> SampledFilter -> SampledFilter -sampledFilterConsumeSample sample sf = - sf - { filter = consume sample $ filter sf - } +sampledFilterConsumeSample :: (MonadIO m) => Sample -> SampledFilter -> m SampledFilter +sampledFilterConsumeSample sample sf = do + filter' <- consume sample $ filter sf + return + sf + { filter = filter' + } diff --git a/src/Nes/APU/State/Filter/Thread.hs b/src/Nes/APU/State/Filter/Thread.hs index 6783428..4802af8 100644 --- a/src/Nes/APU/State/Filter/Thread.hs +++ b/src/Nes/APU/State/Filter/Thread.hs @@ -5,7 +5,6 @@ module Nes.APU.State.Filter.Thread where import Control.Concurrent import Control.Monad import Data.IORef -import Data.Maybe import Nes.APU.State.Filter.Chain import Nes.APU.State.Filter.Class import Nes.APU.State.Filter.Constants @@ -23,25 +22,25 @@ newNoopFilterThread = MkFT (const $ pure ()) (pure 0) Nothing -- | A FilterThread that spawns a process to run the filter chain in the backgroun newFilterThread :: IO FilterThread newFilterThread = do - filtersRef <- newIORef $ newFilterChain defaultOutputRate - inputVar <- newEmptyMVar - getInputVar <- newEmptyMVar + filtersRef <- newIORef =<< newFilterChain defaultOutputRate + inputVar <- newIORef Nothing + getInputVar <- newIORef False postOutputVar <- newEmptyMVar threadId <- Just <$> forkIO (thread filtersRef inputVar getInputVar postOutputVar) - let consumeSample = putMVar inputVar - outputSample = putMVar getInputVar () >> takeMVar postOutputVar + let consumeSample = writeIORef inputVar . Just + outputSample = writeIORef getInputVar True >> takeMVar postOutputVar return $ MkFT{..} -thread :: IORef FilterChain -> MVar Sample -> MVar () -> MVar Sample -> IO () +thread :: IORef FilterChain -> IORef (Maybe Sample) -> IORef Bool -> MVar Sample -> IO () thread filterRef inV getV postV = do - msample <- tryTakeMVar inV + msample <- readIORef inV case msample of Nothing -> pure () - Just sample -> modifyIORef' filterRef (consume sample) + Just sample -> readIORef filterRef >>= consume sample >>= writeIORef filterRef - needOutput <- isJust <$> tryTakeMVar getV + needOutput <- readIORef getV when needOutput $ do - filterOutput <- output <$> readIORef filterRef + filterOutput <- output =<< readIORef filterRef postIsFull <- tryPutMVar postV filterOutput when postIsFull $ return () -- NOTE Shouldn't happen thread filterRef inV getV postV