synthesizer-llvm 0.6 → 0.7
raw patch · 61 files changed
+2120/−1558 lines, 61 filesdep ~llvm-extradep ~llvm-tfdep ~non-empty
Dependency ranges changed: llvm-extra, llvm-tf, non-empty, numeric-prelude, storable-record, storablevector, synthesizer-core, tfp, transformers
Files
- alsa/Synthesizer/LLVM/Server/Packed/Test.hs +8/−8
- alsa/Synthesizer/LLVM/Server/Scalar/Run.hs +1/−1
- alsa/Synthesizer/LLVM/Server/Scalar/Test.hs +1/−1
- example/Synthesizer/LLVM/LAC2011.hs +3/−3
- example/Synthesizer/LLVM/LNdW2011.hs +7/−4
- example/Synthesizer/LLVM/Test.hs +99/−42
- jack/Synthesizer/LLVM/Server/JACK.hs +1/−1
- src/Synthesizer/LLVM/Alloc.hs +1/−18
- src/Synthesizer/LLVM/Causal/Process.hs +406/−68
- src/Synthesizer/LLVM/Causal/ProcessPacked.hs +179/−0
- src/Synthesizer/LLVM/Causal/ProcessPrivate.hs +9/−0
- src/Synthesizer/LLVM/CausalParameterized/Controlled.hs +7/−7
- src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs +8/−8
- src/Synthesizer/LLVM/CausalParameterized/Functional.hs +110/−5
- src/Synthesizer/LLVM/CausalParameterized/Helix.hs +9/−9
- src/Synthesizer/LLVM/CausalParameterized/Process.hs +134/−293
- src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs +33/−167
- src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs +28/−39
- src/Synthesizer/LLVM/Complex.hs +1/−1
- src/Synthesizer/LLVM/ConstantPiece.hs +9/−9
- src/Synthesizer/LLVM/Debug/Storable.hs +7/−5
- src/Synthesizer/LLVM/EventIterator.hs +4/−5
- src/Synthesizer/LLVM/Execution.hs +5/−28
- src/Synthesizer/LLVM/Filter/Allpass.hs +260/−66
- src/Synthesizer/LLVM/Filter/Butterworth.hs +12/−17
- src/Synthesizer/LLVM/Filter/Chebyshev.hs +14/−16
- src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs +1/−1
- src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs +4/−4
- src/Synthesizer/LLVM/Filter/Moog.hs +22/−21
- src/Synthesizer/LLVM/Filter/NonRecursive.hs +6/−6
- src/Synthesizer/LLVM/Filter/SecondOrder.hs +2/−2
- src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs +38/−32
- src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs +4/−4
- src/Synthesizer/LLVM/Filter/Universal.hs +1/−1
- src/Synthesizer/LLVM/Frame.hs +5/−5
- src/Synthesizer/LLVM/Frame/SerialVector.hs +40/−30
- src/Synthesizer/LLVM/Frame/Stereo.hs +1/−1
- src/Synthesizer/LLVM/Frame/StereoInterleaved.hs +32/−30
- src/Synthesizer/LLVM/Generator/Exponential2.hs +17/−15
- src/Synthesizer/LLVM/Interpolation.hs +1/−1
- src/Synthesizer/LLVM/MIDI.hs +7/−10
- src/Synthesizer/LLVM/MIDI/BendModulation.hs +1/−1
- src/Synthesizer/LLVM/Parameterized/Signal.hs +58/−50
- src/Synthesizer/LLVM/Parameterized/SignalPacked.hs +63/−206
- src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs +61/−98
- src/Synthesizer/LLVM/Plug/Input.hs +8/−6
- src/Synthesizer/LLVM/Random.hs +35/−31
- src/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs +4/−2
- src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs +1/−1
- src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs +3/−0
- src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs +2/−2
- src/Synthesizer/LLVM/Server/CommonPacked.hs +4/−2
- src/Synthesizer/LLVM/Server/Packed/Instrument.hs +9/−9
- src/Synthesizer/LLVM/Simple/Signal.hs +76/−82
- src/Synthesizer/LLVM/Simple/SignalPacked.hs +166/−0
- src/Synthesizer/LLVM/Simple/Value.hs +6/−2
- src/Synthesizer/LLVM/Storable/Process.hs +3/−3
- src/Synthesizer/LLVM/Storable/Signal.hs +36/−29
- synthesizer-llvm.cabal +30/−35
- testsuite/Test/Synthesizer/LLVM/Filter.hs +14/−12
- testsuite/Test/Synthesizer/LLVM/Packed.hs +3/−3
alsa/Synthesizer/LLVM/Server/Packed/Test.hs view
@@ -287,7 +287,7 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period pos/sampleRatePlain])+ (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel@@ -384,7 +384,7 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period pos/sampleRatePlain])+ (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp in osc () sustainFM@@ -402,7 +402,7 @@ (\osc smp _fm _vel freq dur -> case SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period (Sample.positions smp) / sampleRatePlain])+ (Serial.replicate (freq*Sample.period (Sample.positions smp) / sampleRatePlain)) :: SigSt.T Vector) of (sustainFM, releaseFM) -> osc () sustainFM@@ -421,7 +421,7 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period pos/sampleRatePlain])+ (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp in SigSt.map (\x -> Stereo.cons x x) sustainFM@@ -442,7 +442,7 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period pos/sampleRatePlain])+ (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp in osc ()@@ -462,7 +462,7 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period pos/sampleRatePlain])+ (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp in osc () sustainFM@@ -487,7 +487,7 @@ let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (SigSt.repeat Option.defaultChunkSize- (Serial.fromList [freq*Sample.period pos/sampleRatePlain])+ (Serial.replicate (freq*Sample.period pos/sampleRatePlain)) :: SigSt.T Vector) pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel@@ -579,7 +579,7 @@ let dur = NonNegChunky.fromChunks $ repeat $ SVL.chunkSize 10 !(sustainFM, releaseFM) = SVP.splitAt dur $- (SigSt.repeat Option.defaultChunkSize (Serial.fromList [1])+ (SigSt.repeat Option.defaultChunkSize (Serial.replicate 1) :: SigSt.T Vector) in case 3::Int of -- no leak
alsa/Synthesizer/LLVM/Server/Scalar/Run.hs view
@@ -14,7 +14,7 @@ import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Wave as WaveL-import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($*), )+import Synthesizer.LLVM.Causal.Process (($<#), ($*), ) import qualified Synthesizer.Storable.Signal as SigSt
alsa/Synthesizer/LLVM/Server/Scalar/Test.hs view
@@ -13,7 +13,7 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Wave as WaveL-import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($*), )+import Synthesizer.LLVM.Causal.Process (($<#), ($*), ) import qualified Synthesizer.Storable.Cut as CutSt import qualified Synthesizer.Storable.Signal as SigSt
example/Synthesizer/LLVM/LAC2011.hs view
@@ -32,12 +32,12 @@ import LLVM.Core (Value, value, valueOf, Vector, constVector, constOf, ) import LLVM.Util.Arithmetic () -- Floating instance for TValue import qualified LLVM.Core as LLVM-import Types.Data.Num (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, )-import qualified Types.Data.Num as TypeNum+import Type.Data.Num.Decimal (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, )+import qualified Type.Data.Num.Decimal as TypeNum import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS import qualified Synthesizer.LLVM.Parameterized.Signal as GenP-import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), )+import Synthesizer.LLVM.Causal.Process (($<), ($*), ($*#), ) import Synthesizer.LLVM.Parameter (($#), ) import qualified Synthesizer.Plain.Filter.Recursive as FiltR
example/Synthesizer/LLVM/LNdW2011.hs view
@@ -46,12 +46,13 @@ import LLVM.Core (Value, value, valueOf, constVector, constOf, ) import LLVM.Util.Arithmetic () -- Floating instance for TValue import qualified LLVM.Core as LLVM-import Types.Data.Num (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, )-import qualified Types.Data.Num as TypeNum +import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, )+ import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS import qualified Synthesizer.LLVM.Parameterized.Signal as GenP-import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), ($<#), )+import Synthesizer.LLVM.Causal.Process (($<), ($*), ($*#), ($<#), ) import Synthesizer.LLVM.Parameter (($#), ) import qualified Synthesizer.Plain.Filter.Recursive as FiltR@@ -184,7 +185,9 @@ type VectorValue = Serial.Value VectorSize Float vectorSize :: Int-vectorSize = TypeNum.fromIntegerT (undefined :: VectorSize)+vectorSize =+ TypeNum.integralFromSingleton+ (TypeNum.singleton :: TypeNum.Singleton VectorSize) vectorRate :: Field.C a => a vectorRate = sampleRate / fromIntegral vectorSize
example/Synthesizer/LLVM/Test.hs view
@@ -25,9 +25,16 @@ import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Interpolation as Interpolation import qualified Synthesizer.LLVM.Simple.Signal as Sig+import qualified Synthesizer.LLVM.Simple.Value as Value import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Wave as Wave import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )+import Synthesizer.LLVM.Causal.Process (($<), ($>), ($*), ($*#), )+import Synthesizer.LLVM.Simple.Value ((%>), (%&&), )+import Synthesizer.LLVM.Parameter (($#), ) import qualified Synthesizer.LLVM.Server.SampledSound as Sample @@ -38,24 +45,21 @@ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A-import LLVM.Core (Value, value, valueOf, Vector, constVector, constOf, )-import LLVM.Util.Arithmetic () -- Floating instance for TValue+import qualified LLVM.Extra.Maybe as Maybe+ import qualified LLVM.Core as LLVM-import Types.Data.Num (D4, D8, D16, )-import qualified Types.Data.Num as TypeNum+import LLVM.Core (Value, valueOf, Vector, )+import LLVM.Util.Arithmetic () -- Floating instance for TValue -import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS-import qualified Synthesizer.LLVM.Parameterized.Signal as SigP-import Synthesizer.LLVM.CausalParameterized.Process (($*#), )-import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )-import Synthesizer.LLVM.Simple.Value ((%>), )-import Synthesizer.LLVM.Parameter (($#), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D4, D8, D16, )+import Type.Base.Proxy (Proxy, ) import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.Causal.Class as CausalClass import qualified Synthesizer.Zip as Zip import qualified Synthesizer.State.Control as CtrlS import qualified Synthesizer.State.Signal as SigS-import Synthesizer.Causal.Class (($<), ($*), ) import qualified Synthesizer.Plain.Filter.Recursive as FiltR import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core@@ -81,7 +85,9 @@ import qualified Sound.Sox.Play as SoxPlay -- import qualified Synthesizer.ALSA.Storable.Play as Play +import qualified Data.NonEmpty.Class as NonEmptyC import qualified Data.NonEmpty as NonEmpty+import qualified Data.Empty as Empty import Data.NonEmpty ((!:), ) import Data.Traversable (sequenceA, ) import Data.Word (Word32, )@@ -188,7 +194,7 @@ SV.writeFile "speedtest.f32" $ asMonoPacked $ (\xs -> SigP.render xs (div 10000000 4) ()) $- SigP.mapSimple Wave.triangle $+ Sig.map Wave.triangle $ SigPS.packSmall $ SigP.osciCore 0.25 (frequency 4.015803e-4) @@ -231,7 +237,7 @@ SigStL.unpackStereoStrict $ asStereoInterleaved $ (\xs -> SigP.render xs (div 10000000 4) ()) $- SigP.mapSimple StereoInt.interleave $+ Sig.map StereoInt.interleave $ liftA2 Stereo.cons (CausalPS.shapeModOsci Wave.rationalApproxSine1 $< (0.001 + SigPS.rampInf 10000000)@@ -249,12 +255,11 @@ (Sig.exponential2 50000 1) (Sig.osciSaw 0.5 freq) -pingSigP :: SigP.T Float (Value Float)-pingSigP =- let freq = id- in SigP.envelope- (SigP.exponential2 50000 1)- (SigP.osciSaw 0.5 freq)+pingSigP :: Param.T p Float -> SigP.T p (Value Float)+pingSigP freq =+ SigP.envelope+ (SigP.exponential2 50000 1)+ (SigP.osciSaw 0.5 freq) ping :: IO () ping =@@ -323,14 +328,14 @@ in liftA2 Stereo.cons (Sig.map mix4 $ Sig.osciPlain Wave.saw- (value $ constVector $ map constOf [0.0, 0.2, 0.1, 0.4])- (value $ constVector $- map (constOf . (freq*)) [1.001, 1.003, 0.995, 0.996]))+ (valueOf $ LLVM.vector $ 0.0 !: 0.2 !: 0.1 !: 0.4 !: Empty.Cons)+ (valueOf $ LLVM.vector $ fmap (freq*) $+ 1.001 !: 1.003 !: 0.995 !: 0.996 !: Empty.Cons)) (Sig.map mix4 $ Sig.osciPlain Wave.saw- (value $ constVector $ map constOf [0.1, 0.7, 0.5, 0.7])- (value $ constVector $- map (constOf . (freq*)) [1.005, 0.997, 0.999, 1.001]))+ (valueOf $ LLVM.vector $ 0.1 !: 0.7 !: 0.5 !: 0.7 !: Empty.Cons)+ (valueOf $ LLVM.vector $ fmap (freq*) $+ 1.005 !: 0.997 !: 0.999 !: 1.001 !: Empty.Cons)) stereoOsciSawPacked2 :: Float -> Sig.T (Stereo.T (Value Float)) stereoOsciSawPacked2 freq =@@ -339,9 +344,8 @@ Sig.osciPlain (Wave.trapezoidSkew (A.fromRational' 0.2)) (valueOf $ LLVM.toVector (0.0, 0.2, 0.1, 0.4, 0.1, 0.7, 0.5, 0.7))- (value $ constVector $- map (constOf . (freq*)) $- [1.001, 1.003, 0.995, 0.996, 1.005, 0.997, 0.999, 1.001])+ (valueOf $ LLVM.vector $ fmap (freq*) $+ 1.001 !: 1.003 !: 0.995 !: 0.996 !: 1.005 !: 0.997 !: 0.999 !: 1.001 !: Empty.Cons) stereo :: IO () stereo =@@ -424,8 +428,8 @@ Param.T p Float -> SigP.T p a lfoSine f reduct =- SigP.mapSimple f $- SigP.mapSimple (\x -> 0.01 * exp (2 * return x)) $+ Sig.map f $+ Sig.map (\x -> 0.01 * exp (2 * return x)) $ SigP.osciSimple Wave.sine 0 (reduct * 0.1/44100) filterSweep :: IO ()@@ -460,9 +464,9 @@ $< (SigP.constant $# Filt2Core.Parameter (1::Float) 0 0 0 0.99) $* (--- (CausalP.delay1 $# Serial.fromList [0.1,0.01,0.001,0.0001::Float])--- (CausalP.delay1 $# Serial.fromList [1::Float])- (CausalP.delay1 $# Serial.fromList ((1::Float):repeat 0))+-- (CausalP.delay1 $# Serial.fromFixedList (0.1 !: 0.01 !: 0.001 !: 0.0001 !: Empty.Cons))+-- (CausalP.delay1 $# Serial.replicate (1::Float))+ (CausalP.delay1 $# Serial.fromFixedList ((1::Float) !: NonEmptyC.repeat 0)) $* 0)) filterSweepPacked2 :: IO ()@@ -511,7 +515,7 @@ asMonoPacked $ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ (CausalPS.amplify 0.2 . Filt2.causalPacked- $< (SigP.mapSimple (const $ Memory.load =<< LLVM.alloca) $+ $< (Sig.map (const $ Memory.load =<< LLVM.alloca) $ (SigP.constant $# (0::Float))) $* SigPS.noise 0 0.3) @@ -522,7 +526,7 @@ asMono $ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $ (0.2 * Filt2.causal- $< (SigP.mapSimple (const $+ $< (Sig.map (const $ (Memory.load =<< LLVM.alloca :: LLVM.CodeGenFunction r (Filt2.Parameter (Value Float)))) $ (SigP.constant $# (0::Float)))@@ -536,7 +540,7 @@ asMono $ Sig.renderChunky (SVL.chunkSize 100000) $ (let reduct = 128 :: Float- in Sig.interpolateConstant reduct $+ in flip Causal.applyConst reduct $ Causal.interpolateConstant $ Sig.osci Wave.sine 0 (reduct*0.1/44100)) @@ -549,7 +553,7 @@ BandPass.causal <<< Causal.feedFst (let reduct = 128- in Sig.interpolateConstant reduct $+ in flip Causal.applyConst reduct $ Causal.interpolateConstant $ Sig.map (BandPass.parameter (valueOf 100)) $ Sig.map (\x -> 0.01 * exp (2 * return x)) $ Sig.osci Wave.sine 0 (reduct*0.1/44100))@@ -923,7 +927,7 @@ pingVec (SVL.chunkSize 4321) . (0.01*)) [1,1.25,1.5,2])- (SigP.runChunky pingSigP)+ (SigP.runChunky $ pingSigP id) {- Arrange itself does not seem to have a space leak with temporary data.@@ -1532,8 +1536,8 @@ allpassControl ::- (TypeNum.NaturalT n) =>- n ->+ (TypeNum.Natural n) =>+ Proxy n -> SigP.T Float (Allpass.CascadeParameter n (Value Float)) allpassControl order = let reduct = id@@ -1550,8 +1554,8 @@ allpassPhaserPipeline = let order = TypeNum.d16- in -- (F.nest (TypeNum.fromIntegerT order) SigP.tail .) $- SigP.drop (return $ TypeNum.fromIntegerT order) .+ in -- (F.nest (TypeNum.integralFromProxy order) SigP.tail .) $+ SigP.drop (return $ TypeNum.integralFromProxy order) . CausalP.apply (0.5 * Allpass.phaserPipeline $< allpassControl order) @@ -1926,6 +1930,59 @@ (let vectorSize = 4 in CausalP.take (pure $ div 100000 vectorSize) $* (Helix.zigZagPacked id $* 0.0001))+++trigger :: IO ()+trigger =+ SVL.writeFile "speedtest.f32" . asMono .+ (\f -> f SVL.defaultChunkSize (0.01 :: Float)) =<<+ SigP.runChunky+ (let pause len =+ CausalClass.applyConst (CausalP.take len) Maybe.nothing+ pulse :: Float -> Param.T p Int -> SigP.T p (Maybe.T (Value Float))+ pulse freq len =+ CausalP.take len .+ arr (flip Maybe.fromBool (valueOf freq)) .+ CausalP.delay1 (pure True) $*# False+ in Sig.zipWith (flip Maybe.select) (SigP.noise 0 0.01) $+ (CausalP.trigger+ (\_ freq -> CausalP.take 150000 $* pingSigP freq) $*+ pause 50000 `SigP.append`+ pulse 0.004 100000 `SigP.append`+ pulse 0.005 200000 `SigP.append`+ pulse 0.006 400000))+++triggerLFO :: SigP.T p (Value Float)+triggerLFO =+ SigP.osciSimple Wave.approxSine2 0 (pure (0.00015 :: Float))+ ++ SigP.osciSimple Wave.approxSine2 0 (pure (0.000037 :: Float))++trackZeros :: CausalP.T p (Value Float) (Value Bool)+trackZeros =+ CausalV.zipWith (\x y -> x %&& Value.not y) .+ (id &&& CausalP.delay1 (pure False)) .+ CausalV.map (%> 0)++fmPingSig :: Param.T p Float -> Param.T p Float -> SigP.T p (Value Float)+fmPingSig freq depth =+ SigP.envelope+ (SigP.exponential2 5000 1)+ ((CausalP.osciSimple Wave.approxSine2 $> SigP.constant freq)+ $*+ (SigP.constant depth * SigP.osciSimple Wave.approxSine2 0 (2*freq)))++sweepTrigger :: IO ()+sweepTrigger =+ SVL.writeFile "speedtest.f32" . asMono .+ (\f -> f SVL.defaultChunkSize (0.01 :: Float)) =<<+ SigP.runChunky+ (Sig.zipWith (flip Maybe.select) (SigP.noise 0 0.01) $+ (CausalP.trigger (const $ fmPingSig (pure (0.005 :: Float))) $*+ liftA2 Maybe.fromBool+ (CausalP.take 10000000 . trackZeros $* triggerLFO)+ (5 * SigP.osciSimple Wave.approxSine2 0 (pure (0.00001 :: Float))))) main :: IO ()
jack/Synthesizer/LLVM/Server/JACK.hs view
@@ -42,7 +42,7 @@ import qualified Control.Monad.Exception.Synchronous as Exc import qualified Control.Monad.Trans.Class as MT -import Control.Arrow (Arrow, (<<<), (^<<), arr, )+import Control.Arrow ((<<<), (^<<), arr, ) import Control.Category (id, ) import Control.Applicative (pure, )
src/Synthesizer/LLVM/Alloc.hs view
@@ -10,29 +10,12 @@ {- reexport alloca and with, since they work correctly in GHC-6.12.3 -} import qualified Foreign as F+import Foreign.Storable.FixedArray (sizeOfArray, roundUp, ) import Foreign.Storable (Storable, sizeOf, alignment, ) import Foreign.Ptr (Ptr, minusPtr, plusPtr, nullPtr, ) import qualified Synthesizer.LLVM.Debug.Storable as Debug --{--Copied from storable-record:FixedArray--}-{-# INLINE roundUp #-}-roundUp :: Int -> Int -> Int-roundUp m x = x + mod (-x) m--{--{-# INLINE roundDown #-}-roundDown :: Int -> Int -> Int-roundDown m x = x - mod x m--}--{-# INLINE sizeOfArray #-}-sizeOfArray :: Storable a => Int -> a -> Int-sizeOfArray n x =- n * roundUp (alignment x) (sizeOf x) {- diffClip :: Int -> Int -> Int
src/Synthesizer/LLVM/Causal/Process.hs view
@@ -5,26 +5,39 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Causal.Process (- C(simple, loopConst, replicateControlled),+ C(simple, alter, replicateControlled), T,+ Core(Core),+ alterSignal, amplify, amplifyStereo, apply, applyFst, applySnd,- compose,- envelope,- envelopeStereo,+ applyConst,+ applyConstFst,+ applyConstSnd,+ (CausalClass.$<), (CausalClass.$>), (CausalClass.$*),+ ($<#), ($>#), ($*#), feedFst, feedSnd,+ feedConstFst,+ feedConstSnd,+ first,+ envelope,+ envelopeStereo, fromModifier, fromSignal, toSignal,+ loopConst, loopZero,+ delay1Zero, feedbackControlledZero, map, mapAccum, zipWith,+ mapProc,+ zipProcWith, mix, pipeline, stereoFromVector,@@ -32,6 +45,14 @@ replaceChannel, arrayElement, element,+ osciCoreSync,+ osciCore,+ osci,+ shapeModOsci,+ skip,+ frequencyModulation,+ interpolateConstant,+ quantizeLift, applyStorable, applyStorableChunky, runStorableChunky,@@ -46,14 +67,18 @@ import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.Causal.Class as CausalClass+import qualified Synthesizer.Causal.Utility as ArrowUtil import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB +import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.MaybeContinuation as MaybeCont import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.ForeignPtr as ForeignPtr@@ -68,20 +93,21 @@ IsConst, IsFirstClass, IsArithmetic, IsPrimitive, Linkage(ExternalLinkage), createNamedFunction) -import qualified Types.Data.Num as TypeNum-import qualified Types.Data.Bool as TypeBool-import Types.Data.Num (D2, )-import Types.Data.Ord ((:<:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Base.Proxy (Proxy, )+import Type.Data.Num.Decimal (D2, (:<:), ) import qualified Control.Arrow as Arr import qualified Control.Category as Cat import Control.Monad.Trans.State (runState, )-import Control.Arrow ((<<<), (^<<), (>>>), (&&&), )+import Control.Arrow (arr, (<<<), (>>>), (&&&), ) import Control.Monad (liftM2, liftM3, ) import Control.Applicative (Applicative, pure, (<*>), ) import qualified Data.List as List+import Data.Tuple.HT (swap, ) import Data.Word (Word32, )+ import Foreign.Storable (Storable, ) import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, ) import Foreign.Ptr (FunPtr, Ptr, )@@ -117,6 +143,22 @@ -- finalization from IO monad +data Core context initState exitState a b =+ forall state.+ (Memory.C state) =>+ Core (forall r c.+ (Phi c) =>+ context ->+ a -> state -> MaybeCont.T r c (b, state))+ -- compute next value+ (forall r.+ initState ->+ CodeGenFunction r state)+ -- initial state+ (state -> exitState)+ -- extract final state for cleanup++ class CausalClass.C process => C process where simple :: (Memory.C state) =>@@ -125,18 +167,18 @@ a -> state -> MaybeCont.T r c (b, state)) -> (forall r. CodeGenFunction r state) -> process a b- {- |- Like 'Synthesizer.LLVM.CausalParameterized.loop'- but uses zero as initial value- and it does not need a zero as Haskell value.- -}- loopConst ::- (Memory.C c) =>- c -> process (a,c) (b,c) -> process a b++ alter ::+ (forall context initState exitState.+ Core context initState exitState a0 b0 ->+ Core context initState exitState a1 b1) ->+ process a0 b0 -> process a1 b1+ replicateControlled :: (Undefined x, Phi x) => Int -> process (c,x) x -> process (c,x) x + instance CausalClass.C T where type SignalOf T = Sig.T type ProcessOf Sig.T = T@@ -150,18 +192,19 @@ (const start) (return ()) (const $ return ())- loopConst init (Cons next start create delete) =- Cons- (Causal.loopNext next)- (fmap ((,) init) . start)- create- delete++ alter f (Cons next0 start0 create delete) =+ case f (Core next0 start0 id) of+ Core next1 start1 _ ->+ Cons next1 start1 create delete+ {- Could be implemented with a machine code loop like in CausalParameterized. But to this end we would need a 'stop' function. -} replicateControlled = CausalClass.replicateControlled + toSignal :: T () a -> Sig.T a toSignal (Cons next start createIOContext deleteIOContext) = Sig.Cons (\ioContext -> next ioContext ())@@ -198,6 +241,22 @@ zipWith f = map (uncurry f) +mapProc ::+ (C process) =>+ (forall r. b -> CodeGenFunction r c) ->+ process a b ->+ process a c+mapProc f x = map f <<< x++zipProcWith ::+ (C process) =>+ (forall r. b -> c -> CodeGenFunction r d) ->+ process a b ->+ process a c ->+ process a d+zipProcWith f x y = zipWith f <<< x&&&y++ fromModifier :: (C process) => (Value.Flatten ah, Value.Registers ah ~ al,@@ -225,13 +284,68 @@ feedSnd :: Sig.T a -> T b (b,a) feedSnd = CausalClass.feedSnd +feedConstFst ::+ (MakeValueTuple a, ValueTuple a ~ al) =>+ a -> T b (al,b)+feedConstFst = CausalClass.feedConstFst . Class.valueTupleOf +feedConstSnd ::+ (MakeValueTuple a, ValueTuple a ~ al) =>+ a -> T b (b,al)+feedConstSnd = CausalClass.feedConstSnd . Class.valueTupleOf++ applyFst :: T (a,b) c -> Sig.T a -> T b c applyFst = CausalClass.applyFst applySnd :: T (a,b) c -> Sig.T b -> T a c applySnd = CausalClass.applySnd +applyConst ::+ (MakeValueTuple a, ValueTuple a ~ al) =>+ T al b -> a -> Sig.T b+applyConst proc =+ CausalClass.applyConst proc . Class.valueTupleOf++applyConstFst ::+ (MakeValueTuple a, ValueTuple a ~ al) =>+ T (al,b) c -> a -> T b c+applyConstFst proc =+ CausalClass.applyConstFst proc . Class.valueTupleOf++applyConstSnd ::+ (MakeValueTuple b, ValueTuple b ~ bl) =>+ T (a,bl) c -> b -> T a c+applyConstSnd proc =+ CausalClass.applyConstSnd proc . Class.valueTupleOf+++infixl 0 $<#, $>#, $*#++{- |+provide constant input in a comfortable way+-}+($*#) ::+ (C process, CausalClass.SignalOf process ~ signal,+ Storable ah, MakeValueTuple ah, ValueTuple ah ~ a,+ Memory.C a) =>+ process a b -> ah -> signal b+proc $*# x = CausalClass.applyConst proc $ Class.valueTupleOf x++($<#) ::+ (C process,+ Storable ah, MakeValueTuple ah, ValueTuple ah ~ a, Memory.C a) =>+ process (a,b) c -> ah -> process b c+proc $<# x = CausalClass.applyConstFst proc $ Class.valueTupleOf x++($>#) ::+ (C process,+ Storable bh, MakeValueTuple bh, ValueTuple bh ~ b, Memory.C b) =>+ process (a,b) c -> bh -> process a c+proc $># x = CausalClass.applyConstSnd proc $ Class.valueTupleOf x+++ compose :: T a b -> T b c -> T a c compose (Cons nextA startA createIOContextA deleteIOContextA)@@ -252,14 +366,11 @@ deleteIOContextB cb) -first :: T b c -> T (b, d) (c, d)-first (Cons next start createIOContext deleteIOContext) = Cons- (\ioContext (b,d) sa0 ->- fmap- (\(c,sa1) -> ((c,d), sa1))- (next ioContext b sa0))- start- createIOContext deleteIOContext+first :: (C process) => process b c -> process (b, d) (c, d)+first =+ alter+ (\(Core next start stop) ->+ Core (Causal.firstNext next) start stop) instance Cat.Category T where@@ -273,49 +384,55 @@ instance Functor (T a) where- fmap = (^<<)+ fmap = ArrowUtil.map instance Applicative (T a) where- pure x = Arr.arr (const x)- f <*> x = uncurry ($) ^<< f&&&x+ pure = ArrowUtil.pure+ (<*>) = ArrowUtil.apply instance (A.Additive b) => Additive.C (T a b) where zero = pure A.zero- negate x = map A.neg <<< x- x + y = zipWith A.add <<< x&&&y- x - y = zipWith A.sub <<< x&&&y+ negate = mapProc A.neg+ (+) = zipProcWith A.add+ (-) = zipProcWith A.sub instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T a b) where one = pure A.one fromInteger n = pure (A.fromInteger' n)- x * y = zipWith A.mul <<< x&&&y+ (*) = zipProcWith A.mul instance (A.Field b, A.RationalConstant b) => Field.C (T a b) where fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)- x / y = zipWith A.fdiv <<< x&&&y+ (/) = zipProcWith A.fdiv instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => P.Num (T a b) where fromInteger n = pure (A.fromInteger' n)- negate x = map A.neg <<< x- x + y = zipWith A.add <<< x&&&y- x - y = zipWith A.sub <<< x&&&y- x * y = zipWith A.mul <<< x&&&y- abs x = map A.abs <<< x- signum x = map A.signum <<< x+ negate = mapProc A.neg+ (+) = zipProcWith A.add+ (-) = zipProcWith A.sub+ (*) = zipProcWith A.mul+ abs = mapProc A.abs+ signum = mapProc A.signum instance (A.Field b, A.Real b, A.RationalConstant b) => P.Fractional (T a b) where fromRational x = pure (A.fromRational' x)- x / y = zipWith A.fdiv <<< x&&&y+ (/) = zipProcWith A.fdiv +{- |+You may also use '(+)'.+-} mix :: (C process, A.Additive a) => process (a, a) a mix = zipWith Frame.mix +{- |+You may also use '(*)'.+-} envelope :: (C process, A.PseudoRing a) => process (a, a) a@@ -340,19 +457,69 @@ +loopConst ::+ (C process, Memory.C c) =>+ c -> process (a,c) (b,c) -> process a b+loopConst init =+ alter+ (\(Core next start stop) ->+ Core+ (Causal.loopNext next)+ (fmap ((,) init) . start)+ (stop . snd))++{- |+Like 'Synthesizer.LLVM.CausalParameterized.loop'+but uses zero as initial value+and it does not need a zero as Haskell value.+-} loopZero :: (C process, A.Additive c, Memory.C c) => process (a,c) (b,c) -> process a b loopZero = loopConst A.zero +delay1Zero ::+ (C process, A.Additive a, Memory.C a) =>+ process a a+delay1Zero = loopZero (arr swap)+++{- |+This allows to compute a chain of equal processes efficiently,+if all of these processes can be bundled in one vectorial process.+Applications are an allpass cascade or an FM operator cascade.++The function expects that the vectorial input process+works like parallel scalar processes.+The different pipeline stages may be controlled by different parameters,+but the structure of all pipeline stages must be equal.+Our function feeds the input of the pipelined process+to the zeroth element of the Vector.+The result of processing the i-th element (the i-th channel, so to speak)+is fed to the (i+1)-th element.+The (n-1)-th element of the vectorial process is emitted+as output of the pipelined process.++The pipeline necessarily introduces a delay of (n-1) values.+For simplification we extend this to n values delay.+If you need to combine the resulting signal from the pipeline+with another signal in a 'zip'-like way,+you may delay that signal with @pipeline id@.+The first input values in later stages of the pipeline+are initialized with zero.+If this is not appropriate for your application,+then we may add a more sensible initialization.+-} pipeline :: (C process,- Vector.C v, a ~ Vector.Element v,+ TypeNum.Positive n, MultiVector.C x,+ v ~ MultiVector.T n x,+ a ~ MultiValue.T x, Class.Zero v, Memory.C v) => process v v -> process a a pipeline vectorProcess =- loopConst Class.zeroTuple $- map (uncurry Vector.shiftUp)+ loopConst MultiVector.zero $+ map (uncurry MultiVector.shiftUp) >>> Arr.second vectorProcess @@ -386,20 +553,22 @@ -} vectorize :: (C process,- Vector.C va, n ~ Vector.Size va, a ~ Vector.Element va,- Vector.C vb, n ~ Vector.Size vb, b ~ Vector.Element vb) =>+ TypeNum.Positive n,+ MultiVector.C x, MultiValue.T x ~ a, MultiVector.T n x ~ va,+ MultiVector.C y, MultiValue.T y ~ b, MultiVector.T n y ~ vb) => process a b -> process va vb vectorize proc = withSize $ \n -> foldl (\acc i -> replaceChannel i proc acc)- (Arr.arr (const $ Class.undefTuple)) $- List.take (TypeNum.fromIntegerT n) [0 ..]+ (arr (const $ Class.undefTuple)) $+ List.take (TypeNum.integralFromSingleton n) [0 ..] withSize ::- (Vector.Size bv -> f bv) ->- f bv-withSize f = f undefined+ (TypeNum.Positive n, MultiVector.T n a ~ v) =>+ (TypeNum.Singleton n -> f v) ->+ f v+withSize f = f TypeNum.singleton {- | Given a vector process, replace the i-th output by output@@ -407,26 +576,24 @@ -} replaceChannel :: (C process,- Vector.C va, n ~ Vector.Size va, a ~ Vector.Element va,- Vector.C vb, n ~ Vector.Size vb, b ~ Vector.Element vb) =>+ TypeNum.Positive n,+ MultiVector.C x, MultiValue.T x ~ a, MultiVector.T n x ~ va,+ MultiVector.C y, MultiValue.T y ~ b, MultiVector.T n y ~ vb) => Int -> process a b -> process va vb -> process va vb replaceChannel i channel proc = let li = valueOf $ fromIntegral i- in zipWith (Vector.insert li) <<<- (channel <<< map (Vector.extract li)) &&&+ in zipWith (MultiVector.insert li) <<<+ (channel <<< map (MultiVector.extract li)) &&& proc {- | Read the i-th element from each array. -} arrayElement ::- (C process,- LLVM.Array dim a ~ array,- LLVM.GetValue array index, IsFirstClass a,- LLVM.ValueType array index ~ a,- TypeNum.NaturalT index, TypeNum.NaturalT dim,- (index :<: dim) ~ TypeBool.True) =>- index -> process (Value (LLVM.Array dim a)) (Value a)+ (C process, IsFirstClass a,+ TypeNum.Natural index, TypeNum.Natural dim,+ index :<: dim) =>+ Proxy index -> process (Value (LLVM.Array dim a)) (Value a) arrayElement i = map (\array -> LLVM.extractvalue array i) @@ -439,6 +606,177 @@ index -> process (Value agg) (Value a) element i = map (\array -> LLVM.extractvalue array i)++++{- |+Compute the phases from phase distortions and frequencies.++It's like integrate but with wrap-around performed by @fraction@.+For FM synthesis we need also negative phase distortions,+thus we use 'A.addToPhase' which supports that.+-}+osciCore, _osciCore, osciCoreSync ::+ (C process, Memory.C t, A.Fraction t) =>+ process (t, t) (t)+_osciCore =+ zipWith A.addToPhase <<<+ Arr.second+ (mapAccum+ (\a s -> do+ b <- A.incPhase a s+ return (s,b))+ (return A.zero))++{-+This could be implemented using a generalized frequencyModulation,+however, osciCoreSync allows for negative phase differences.+-}+osciCoreSync =+ zipWith A.addToPhase <<<+ Arr.second+ (mapAccum+ (\a s -> do+ b <- A.incPhase a s+ return (b,b))+ (return A.zero))++osciCore =+ zipWith A.addToPhase <<<+ Arr.second (loopZero (arr snd &&& zipWith A.incPhase))++osci ::+ (C process, Memory.C t, A.Fraction t) =>+ (forall r. t -> CodeGenFunction r y) ->+ process (t, t) y+osci wave =+ map wave <<< osciCore++shapeModOsci ::+ (C process, Memory.C t, A.Fraction t) =>+ (forall r. c -> t -> CodeGenFunction r y) ->+ process (c, (t, t)) y+shapeModOsci wave =+ zipWith wave <<< Arr.second osciCore++++alterSignal ::+ (C process, CausalClass.SignalOf process ~ signal) =>+ (forall context initState exitState.+ Sig.Core context initState exitState a0 ->+ Core context initState exitState a1 b1) ->+ signal a0 -> process a1 b1+alterSignal f =+ alter (\(Core next start stop) -> f (Sig.Core (\c -> next c ()) start stop))+ .+ CausalClass.fromSignal++{- |+Feeds a signal into a causal process while holding or skipping signal elements+according to the process input.+The skip happens after a value is passed from the fed signal.++@skip x $* 0@ repeats the first signal value in the output.+@skip x $* 1@ feeds the signal to the output as is.+@skip x $* 2@ feeds the signal to the output with double speed.+-}+skip ::+ (C process, CausalClass.SignalOf process ~ signal,+ Undefined v, Phi v, Memory.C v) =>+ signal v -> process (Value Word32) v+skip =+ alterSignal+ (\(Sig.Core next start stop) -> Core+ (\context n1 (yState0,n0) -> do+ (y,state1) <-+ MaybeCont.fromMaybe $ fmap snd $+ MaybeCont.fixedLengthLoop n0 yState0 $+ next context . snd+ return (y, ((y,state1),n1)))+ (fmap (\s -> ((Class.undefTuple, s), A.one)) . start)+ (\((_y,state),_k) -> stop state))++{-+It is quite similar to quantizeLift but the control is the reciprocal.+This is especially a problem since we need the fractional part for interpolation.+-}+frequencyModulation ::+ (C process, CausalClass.SignalOf process ~ signal,+ SoV.IntegerConstant a, LLVM.IsFloating a,+ LLVM.CmpRet a, LLVM.CmpResult a ~ Bool,+ Memory.FirstClass a, Memory.Stored a ~ am, LLVM.IsSized am,+ Undefined nodes, Phi nodes, Memory.C nodes) =>+ (forall r. Value a -> nodes -> CodeGenFunction r v) ->+ signal nodes -> process (Value a) v+frequencyModulation ip =+ alterSignal (\(Sig.Core next start stop) -> Core+ (\context k yState0 -> do+ ((nodes2,state2), ss2) <-+ MaybeCont.fromBool $+ C.whileLoop+ (valueOf True, yState0)+ (\(cont0, (_, ss0)) ->+ LLVM.and cont0 =<< A.fcmp LLVM.FPOGE ss0 A.one)+ (\(_,((_,state0), ss0)) ->+ MaybeCont.toBool $ liftM2 (,)+ (next context state0)+ (MaybeCont.lift $ A.sub ss0 A.one))++ MaybeCont.lift $ do+ y <- ip ss2 nodes2+ ss3 <- A.add ss2 k+ return (y, ((nodes2, state2), ss3)))+ (fmap (\sa -> ((Class.undefTuple, sa), A.one)) . start)+ (\((_y01,state),_ss) -> stop state))+++{- |+Stretch signal in time by a time-varying factor.+-}+interpolateConstant ::+ (C process, CausalClass.SignalOf process ~ signal,+ Memory.C a,+ Memory.FirstClass b, Memory.Stored b ~ bm, LLVM.IsSized bm,+ SoV.IntegerConstant b,+ LLVM.IsFloating b, LLVM.CmpRet b, LLVM.CmpResult b ~ Bool) =>+ signal a -> process (Value b) a+interpolateConstant xs =+ quantizeLift (CausalClass.fromSignal xs) $># ()+++quantizeLift ::+ (C process, Memory.C b,+ SoV.IntegerConstant c, LLVM.IsFloating c,+ LLVM.CmpRet c, LLVM.CmpResult c ~ Bool,+ Memory.FirstClass c, Memory.Stored c ~ cm, LLVM.IsSized cm) =>+ process a b ->+ process (Value c, a) b+quantizeLift = alter (\(Core next start stop) -> Core+ (\context (k, a0) yState0 -> do+ (yState1, frac1) <-+ MaybeCont.fromBool $+ C.whileLoop+ (LLVM.valueOf True, yState0)+ (\(cont1, (_, frac0)) ->+ LLVM.and cont1 =<< A.fcmp LLVM.FPOLE frac0 A.zero)+ (\(_,((_,state01), frac0)) ->+ MaybeCont.toBool $ liftM2 (,)+ (next context a0 state01)+ (MaybeCont.lift $ A.add frac0 k))++ frac2 <- MaybeCont.lift $ A.sub frac1 A.one+ return (fst yState1, (yState1, frac2)))+{- using this initialization code we would not need undefined values+ (do sa <- start+ (a,_) <- next sa+ return (sa, a, A.zero))+-}+ (\p -> do+ s <- start p+ return ((Class.undefTuple, s), A.zero))+ (\((_, s), _) -> stop s))+ applyStorable ::
+ src/Synthesizer/LLVM/Causal/ProcessPacked.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+module Synthesizer.LLVM.Causal.ProcessPacked where++import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C++import qualified LLVM.Core as LLVM+import LLVM.Core+ (CodeGenFunction, Value, valueOf,+ IsSized, IsFirstClass, )++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal ((:<:), )+import Type.Base.Proxy (Proxy, )++import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS+import qualified Control.Arrow as Arr+import Control.Arrow ((<<<), )++import Data.Word (Word32, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- |+Run a scalar process on packed data.+If the signal length is not divisible by the chunk size,+then the last chunk is dropped.+-}+pack ::+ (Causal.C process,+ Serial.Read va, n ~ Serial.Size va, a ~ Serial.Element va,+ Serial.C vb, n ~ Serial.Size vb, b ~ Serial.Element vb) =>+ process a b -> process va vb+pack = Causal.alter (\(Causal.Core next start stop) -> Causal.Core+ (\param a s -> do+ r <- Maybe.lift $ Serial.readStart a+ ((_,w2),(_,s2)) <-+ Maybe.fromBool $+ C.whileLoop+ (valueOf True,+ let w = Class.undefTuple+ in ((r,w),+ (valueOf (fromIntegral $ Serial.sizeOfIterator w :: Word32), s)))+ (\(cont,(_rw0,(i0,_s0))) ->+ A.and cont =<<+ A.cmp LLVM.CmpGT i0 A.zero)+ (\(_,((r0,w0),(i0,s0))) -> Maybe.toBool $ do+ (ai,r1) <- Maybe.lift $ Serial.readNext r0+ (bi,s1) <- next param ai s0+ Maybe.lift $ do+ w1 <- Serial.writeNext bi w0+ i1 <- A.dec i0+ return ((r1,w1),(i1,s1)))+ b <- Maybe.lift $ Serial.writeStop w2+ return (b, s2))+ start+ stop)++{- |+Like 'pack' but duplicates the code for the scalar process.+That is, for vectors of size n,+the code for the scalar causal process will be written n times.+This is efficient only for simple input processes.+-}+packSmall ::+ (Causal.C process,+ Serial.Read va, n ~ Serial.Size va, a ~ Serial.Element va,+ Serial.C vb, n ~ Serial.Size vb, b ~ Serial.Element vb) =>+ process a b -> process va vb+packSmall = Causal.alter (\(Causal.Core next start stop) -> Causal.Core+ (\param a ->+ MS.runStateT $+ (MT.lift . Maybe.lift . Serial.assemble)+ =<<+ mapM (MS.StateT . next param)+ =<<+ (MT.lift $ Maybe.lift $ Serial.extractAll a))+ start+ stop)+++{- |+Run a packed process on scalar data.+If the signal length is not divisible by the chunk size,+then the last chunk is dropped.+In order to stay causal, we have to delay the output by @n@ samples.+-}+unpack ::+ (Causal.C process,+ Serial.Zero va, n ~ Serial.Size va, a ~ Serial.Element va,+ Serial.Read vb, n ~ Serial.Size vb, b ~ Serial.Element vb,+ Memory.C va, Memory.C ita, ita ~ Serial.WriteIt va,+ Memory.C vb, Memory.C itb, itb ~ Serial.ReadIt vb) =>+ process va vb -> process a b+unpack = Causal.alter (\(Causal.Core next start stop) -> Causal.Core+ (\param ai ((w0,r0),(i0,s0)) -> do+ endOfVector <- Maybe.lift $ A.cmp LLVM.CmpEQ i0 A.zero+ ((w2,r2),(i2,s2)) <-+ Maybe.fromBool $+ C.ifThen endOfVector (valueOf True, ((w0,r0),(i0,s0))) $ do+ a0 <- Serial.writeStop w0+ (cont1, (b1,s1)) <- Maybe.toBool $ next param a0 s0+ r1 <- Serial.readStart b1+ w1 <- Serial.writeStart+ return (cont1,+ ((w1, r1),+ (valueOf $ fromIntegral $ Serial.size a0, s1)))+ Maybe.lift $ do+ w3 <- Serial.writeNext ai w2+ (bi,r3) <- Serial.readNext r2+ i3 <- A.dec i2+ return (bi, ((w3,r3),(i3,s2))))+ (\s -> do+ s1 <- start s+ w <- Serial.writeZero+ return ((w, Class.undefTuple), (valueOf (0::Word32), s1)))+ (\(_wr,(_i,state)) -> stop state))+++osciCore ::+ (Causal.C process,+ Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm,+ Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,+ TypeNum.Positive n) =>+ process (Serial.Value n t, Serial.Value n t) (Serial.Value n t)+osciCore =+ Causal.zipWith A.addToPhase <<<+ Arr.second+ (Causal.mapAccum+ (\a phase0 -> do+ (phase1,b1) <- Serial.cumulate phase0 a+ phase2 <- A.signedFraction phase1+ return (b1,phase2))+ (return A.zero))++osci ::+ (Causal.C process,+ Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm,+ Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,+ TypeNum.Positive n) =>+ (forall r. Serial.Value n t -> CodeGenFunction r y) ->+ process (Serial.Value n t, Serial.Value n t) y+osci wave =+ Causal.map wave <<< osciCore++shapeModOsci ::+ (Causal.C process,+ Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm,+ Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,+ TypeNum.Positive n) =>+ (forall r. c -> Serial.Value n t -> CodeGenFunction r y) ->+ process (c, (Serial.Value n t, Serial.Value n t)) y+shapeModOsci wave =+ Causal.zipWith wave <<< Arr.second osciCore++++arrayElement ::+ (Causal.C process,+ IsFirstClass a, LLVM.Value a ~ Serial.Element v, Serial.C v,+ TypeNum.Natural index, TypeNum.Natural dim,+ index :<: dim) =>+ Proxy index -> process (Value (LLVM.Array dim a)) v+arrayElement i =+ Causal.map Serial.upsample <<< Causal.arrayElement i
src/Synthesizer/LLVM/Causal/ProcessPrivate.hs view
@@ -3,6 +3,15 @@ import Control.Arrow (Arrow, arr, (>>>), (&&&), ) +firstNext ::+ (Functor m) =>+ (context -> a -> s -> m (b, s)) ->+ context -> (a, c) -> s -> m ((b, c), s)+firstNext next context (b,d) s0 =+ fmap+ (\(c,s1) -> ((c,d), s1))+ (next context b s0)+ loopNext :: (Monad m) => (context -> (a,c) -> state -> m ((b,c), state)) ->
src/Synthesizer/LLVM/CausalParameterized/Controlled.hs view
@@ -38,8 +38,8 @@ import qualified Synthesizer.LLVM.Frame.Stereo as Stereo -import qualified Types.Data.Num as TypeNum-import Types.Data.Num.Ops ((:*:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal.Number ((:*:), ) import Foreign.Storable (Storable, ) @@ -58,7 +58,7 @@ processCtrlRate :: (C parameter a b, Memory.C parameter,- Memory.FirstClass r, IsSized r, IsSized (Memory.Stored r),+ Memory.FirstClass r, IsSized (Memory.Stored r), IsFloating r, Storable r, SoV.IntegerConstant r, MakeValueTuple r, ValueTuple r ~ (Value r), LLVM.CmpRet r, LLVM.CmpResult r ~ Bool) =>@@ -106,8 +106,8 @@ (a ~ SoV.Scalar v, SoV.PseudoModule v, SoV.IntegerConstant a, Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a), Memory.FirstClass v, IsSized v, IsSized (Memory.Stored v),- TypeNum.NaturalT n,- TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ TypeNum.Natural n,+ TypeNum.Positive (n :*: LLVM.UnknownSize)) => C (Cascade.ParameterValue n a) (Value v) (Value v) where type Input (Cascade.ParameterValue n a) (Value v) = Value v@@ -126,7 +126,7 @@ instance (a ~ A.Scalar v, A.PseudoModule v, A.RationalConstant a, Memory.C a, Memory.C v,- TypeNum.NaturalT n) =>+ TypeNum.Natural n) => C (Allpass.CascadeParameter n a) v v where type Input (Allpass.CascadeParameter n a) v = v type Output (Allpass.CascadeParameter n a) v = v@@ -135,7 +135,7 @@ instance (A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,- Memory.C v, TypeNum.NaturalT n) =>+ Memory.C v, TypeNum.Natural n) => C (Moog.Parameter n a) v v where type Input (Moog.Parameter n a) v = v type Output (Moog.Parameter n a) v = v
src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs view
@@ -35,8 +35,8 @@ import LLVM.Util.Loop (Phi, ) import LLVM.Core (Value, IsFloating, IsSized, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num.Ops ((:*:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal.Number ((:*:), ) import Foreign.Storable (Storable, ) @@ -60,8 +60,8 @@ processCtrlRate :: (C parameter av bv,- Serial.Read av, n ~ Serial.Size av, a ~ Serial.Element av,- Serial.C bv, n ~ Serial.Size bv, b ~ Serial.Element bv,+ Serial.Read av, n ~ Serial.Size av,+ Serial.C bv, n ~ Serial.Size bv, Memory.C parameter, Field.C r, Storable r, IsFloating r, SoV.IntegerConstant r, Memory.FirstClass r, Memory.Stored r ~ rm, IsSized r, IsSized rm,@@ -108,8 +108,8 @@ Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, LLVM.IsPrimitive a, LLVM.IsPrimitive am,- TypeNum.PositiveT (n :*: LLVM.UnknownSize),- TypeNum.NaturalT n) =>+ TypeNum.Positive (n :*: LLVM.UnknownSize),+ TypeNum.Natural n) => C (Cascade.ParameterValue n a) v v where type Input (Cascade.ParameterValue n a) v = v type Output (Cascade.ParameterValue n a) v = v@@ -126,7 +126,7 @@ process = Allpass.causalPacked instance- (TypeNum.NaturalT n,+ (TypeNum.Natural n, Serial.C v, Serial.Element v ~ a, A.PseudoRing a, A.IntegerConstant a, Memory.C a, A.PseudoRing v, A.RationalConstant v) =>@@ -139,7 +139,7 @@ instance (Serial.C v, Serial.Element v ~ b, Phi a, Class.Undefined a, a ~ A.Scalar b, A.PseudoModule b, A.IntegerConstant a, Memory.C b,- TypeNum.NaturalT n) =>+ TypeNum.Natural n) => C (Moog.Parameter n a) v v where type Input (Moog.Parameter n a) v = v type Output (Moog.Parameter n a) v = v
src/Synthesizer/LLVM/CausalParameterized/Functional.hs view
@@ -7,12 +7,19 @@ lift, fromSignal, ($&), (&|&), compile,- withArgs, compileSignal, MakeArguments, Arguments, makeArgs,+ compileSignal,+ withArgs, MakeArguments, Arguments, makeArgs, AnyArg(..),++ Atom(..), atom,+ withGuidedArgs, MakeGuidedArguments, GuidedArguments, PatternArguments,+ makeGuidedArgs, ) where import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP+import qualified Synthesizer.LLVM.Causal.ProcessPrivate as Causal import qualified Synthesizer.LLVM.Parameterized.Signal as Signal+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified LLVM.Extra.MaybeContinuation as Maybe@@ -107,7 +114,7 @@ (const $ return ((),())) (const $ return ()) first (Code next start stop create delete) = Code- (CausalP.firstNext next) start stop+ (Causal.firstNext next) start stop create delete @@ -271,7 +278,8 @@ withArgsStart :: (MakeArguments inp) =>- T p inp inp -> (Arguments (T p inp) inp -> T p inp out) -> CausalP.T p inp out+ T p inp inp ->+ (Arguments (T p inp) inp -> T p inp out) -> CausalP.T p inp out withArgsStart fid f = compile (f (makeArgs fid)) @@ -289,13 +297,23 @@ because we would need a functional depedency from, say, @(Arg a, Arg b)@ to @(a,b)@. This is the opposite direction to the dependency we use currently.+The 'AnyArg' type provides a solution in this spirit. -} type instance Arguments f (LLVM.Value a) = f (LLVM.Value a) instance MakeArguments (LLVM.Value a) where makeArgs = id -type instance Arguments f (Stereo.T a) = f (Stereo.T a)-instance MakeArguments (Stereo.T a) where+{- |+Consistent with pair instance.+You may use 'AnyArg' or 'withGuidedArgs'+to stop descending into the stereo channels.+-}+type instance Arguments f (Stereo.T a) = Stereo.T (Arguments f a)+instance (MakeArguments a) => MakeArguments (Stereo.T a) where+ makeArgs = fmap makeArgs . Stereo.sequence++type instance Arguments f (Serial.T v) = f (Serial.T v)+instance MakeArguments (Serial.T v) where makeArgs = id type instance Arguments f () = f ()@@ -313,8 +331,95 @@ makeArgs f = (makeArgs $ fmap fst3 f, makeArgs $ fmap snd3 f, makeArgs $ fmap thd3 f) +{- |+You can use this to explicitly stop breaking of composed data types.+It might be more comfortable to do this using 'withGuidedArgs'.+-} newtype AnyArg a = AnyArg {getAnyArg :: a} type instance Arguments f (AnyArg a) = f a instance MakeArguments (AnyArg a) where makeArgs = fmap getAnyArg+++++{- |+This is similar to 'withArgs'+but it allows to specify the decomposition depth using a pattern.+-}+withGuidedArgs ::+ (MakeGuidedArguments pat, PatternArguments pat ~ inp) =>+ pat ->+ (GuidedArguments (T p inp) pat -> T p inp out) -> CausalP.T p inp out+withGuidedArgs p = withGuidedArgsStart p (lift Cat.id)++withGuidedArgsStart ::+ (MakeGuidedArguments pat, PatternArguments pat ~ inp) =>+ pat ->+ T p inp inp ->+ (GuidedArguments (T p inp) pat -> T p inp out) -> CausalP.T p inp out+withGuidedArgsStart p fid f = compile (f (makeGuidedArgs p fid))+++data Atom a = Atom++atom :: Atom a+atom = Atom+++type family GuidedArguments (f :: * -> *) pat+type family PatternArguments pat++class MakeGuidedArguments pat where+ makeGuidedArgs ::+ Functor f =>+ pat -> f (PatternArguments pat) -> GuidedArguments f pat+++type instance GuidedArguments f (Atom a) = f a+type instance PatternArguments (Atom a) = a+instance MakeGuidedArguments (Atom a) where+ makeGuidedArgs Atom = id++type instance+ GuidedArguments f (Stereo.T a) =+ Stereo.T (GuidedArguments f a)+type instance+ PatternArguments (Stereo.T a) =+ Stereo.T (PatternArguments a)+instance MakeGuidedArguments a => MakeGuidedArguments (Stereo.T a) where+ makeGuidedArgs pat f =+ Stereo.cons+ (makeGuidedArgs (Stereo.left pat) $ fmap Stereo.left f)+ (makeGuidedArgs (Stereo.right pat) $ fmap Stereo.right f)++type instance GuidedArguments f () = f ()+type instance PatternArguments () = ()+instance MakeGuidedArguments () where+ makeGuidedArgs () = id++type instance+ GuidedArguments f (a,b) =+ (GuidedArguments f a, GuidedArguments f b)+type instance+ PatternArguments (a,b) =+ (PatternArguments a, PatternArguments b)+instance (MakeGuidedArguments a, MakeGuidedArguments b) =>+ MakeGuidedArguments (a,b) where+ makeGuidedArgs (pa,pb) f =+ (makeGuidedArgs pa $ fmap fst f,+ makeGuidedArgs pb $ fmap snd f)++type instance+ GuidedArguments f (a,b,c) =+ (GuidedArguments f a, GuidedArguments f b, GuidedArguments f c)+type instance+ PatternArguments (a,b,c) =+ (PatternArguments a, PatternArguments b, PatternArguments c)+instance (MakeGuidedArguments a, MakeGuidedArguments b, MakeGuidedArguments c) =>+ MakeGuidedArguments (a,b,c) where+ makeGuidedArgs (pa,pb,pc) f =+ (makeGuidedArgs pa $ fmap fst3 f,+ makeGuidedArgs pb $ fmap snd3 f,+ makeGuidedArgs pc $ fmap thd3 f)
src/Synthesizer/LLVM/CausalParameterized/Helix.hs view
@@ -46,8 +46,8 @@ import qualified LLVM.Core as LLVM import LLVM.Core (CodeGenFunction, Value, IsSized, IsFloating, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num (D1, )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D1, ) import Data.Word (Word32, ) @@ -113,7 +113,7 @@ Serial.C (nodesLeap (nodesStep v)), Serial.Element (nodesLeap (nodesStep v)) ~ nodesLeap (nodesStep (Serial.Element v)),- TypeNum.PositiveT n,+ TypeNum.Positive n, SoV.RationalConstant a, SoV.Fraction a, Vector.Real a, Storable a, MakeValueTuple a, ValueTuple a ~ Value a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,@@ -357,7 +357,7 @@ (IsFloating a, Vector.Real a, SoV.RationalConstant a, Storable ah, MakeValueTuple ah, ValueTuple ah ~ Value a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- TypeNum.PositiveT n) =>+ TypeNum.Positive n) => Param.T p Word32 -> Param.T p ah -> CausalP.T p@@ -430,7 +430,7 @@ IsSized tm, LLVM.IsPrimitive tm, LLVM.SizeOf tm ~ tmsize, IsFloating t, LLVM.IsPrimitive t, Vector.Real t,- TypeNum.PositiveT n,+ TypeNum.Positive n, Ip.C nodesStep, Ip.C nodesLeap) => Param.T p (Ip.Margin (nodesLeap (nodesStep value))) -> Param.T p Word32 ->@@ -571,12 +571,12 @@ zigZagLongPacked :: (Storable a, MakeValueTuple a, ValueTuple a ~ Value a, SoV.Fraction a, SoV.RationalConstant a, Vector.Real a,- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, LLVM.IsPrimitive am, Field.C a, (n TypeNum.:*: LLVM.SizeOf am) ~ amsize,- TypeNum.PositiveT amsize,- TypeNum.PositiveT n) =>+ TypeNum.Positive amsize,+ TypeNum.Positive n) => Param.T p a -> Param.T p a -> CausalP.T p (Serial.Value n a) (Serial.Value n a)@@ -616,7 +616,7 @@ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, SoV.Fraction a, Vector.Real a, IsFloating a, SoV.RationalConstant a, LLVM.CmpRet a,- TypeNum.PositiveT n) =>+ TypeNum.Positive n) => Param.T p a -> CausalP.T p (Serial.Value n a) (Serial.Value n a) zigZagPacked start =
src/Synthesizer/LLVM/CausalParameterized/Process.hs view
@@ -11,9 +11,11 @@ feedFst, feedSnd, loop, loopZero, take, takeWhile, integrate, - ($<), ($>), ($*), ($<#), ($>#), ($*#),+ ($<), ($>), ($*), applyFst, applySnd, + reparameterize,+ mapAccumSimple, replicateControlled,@@ -30,23 +32,23 @@ Causal.replaceChannel, Causal.arrayElement, Causal.element,- mix,+ Causal.mix, raise,- envelope,- envelopeStereo,+ Causal.envelope,+ Causal.envelopeStereo, amplify, amplifyStereo, mapLinear, mapExponential, quantizeLift, osciSimple,- osciCore,- osciCoreSync,- shapeModOsci,+ Causal.osciCore,+ Causal.osciCoreSync,+ Causal.shapeModOsci, delay, delayZero, delay1,- delay1Zero,+ Causal.delay1Zero, delayControlled, delayControlledInterpolated, differentiate,@@ -54,12 +56,10 @@ combStereo, reverb, reverbEfficient,- pipeline,- skip,- frequencyModulation,+ Causal.pipeline,+ Causal.skip,+ Causal.frequencyModulation, frequencyModulationLinear,- adjacentNodes02,- adjacentNodes13, trigger, runStorable,@@ -74,19 +74,17 @@ import Synthesizer.LLVM.CausalParameterized.ProcessPrivate import Synthesizer.LLVM.Causal.ProcessPrivate (feedbackControlledAux, )-import Synthesizer.LLVM.Causal.Process (loopZero, )+import Synthesizer.LLVM.Causal.Process (loopZero, mix, ) import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Plug.Input as PIn import qualified Synthesizer.LLVM.Plug.Output as POut import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.CausalIO.Process as PIO -import Synthesizer.LLVM.Parameterized.SignalPrivate- (withStart, quantizeCreate, quantizeDelete,- quantizeNext, quantizeStart, quantizeStop, ) import Synthesizer.LLVM.Parameter (($#), ) import qualified Synthesizer.LLVM.RingBuffer as RingBuffer-import qualified Synthesizer.LLVM.Parameterized.Signal as Sig+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Simple.Signal as Sig import qualified Synthesizer.LLVM.Interpolation as Interpolation import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame@@ -100,13 +98,11 @@ import qualified Synthesizer.Causal.Class as CausalClass import qualified LLVM.Extra.ScalarOrVector as SoV-import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.MaybeContinuation as MaybeCont import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.ForeignPtr as ForeignPtr import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) @@ -117,15 +113,14 @@ IsSized, IsConst, IsArithmetic, IsFloating, Linkage(ExternalLinkage), createNamedFunction, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num (D1, )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D1, ) import qualified Control.Monad.HT as M-import qualified Control.Arrow as Arr import qualified Control.Category as Cat import qualified Control.Monad.Trans.State as MS import Control.Monad.Trans.State (evalState, )-import Control.Arrow (arr, second, (<<<), (<<^), (>>>), (&&&), )+import Control.Arrow (arr, first, second, (<<<), (<<^), (>>>), (&&&), ) import Control.Monad (liftM, liftM2, liftM3, when, ) import Control.Applicative (liftA2, liftA3, pure, (<*>), ) import Control.Functor.HT (void, unzip, )@@ -133,7 +128,7 @@ import qualified Data.List as List import Data.Traversable (traverse, ) import Data.Foldable (sequence_, )-import Data.Tuple.HT (swap, mapSnd, uncurry3, snd3, )+import Data.Tuple.HT (swap, mapFst, mapSnd, uncurry3, snd3, ) import Data.Word (Word32, ) import Data.Int (Int8, ) @@ -146,9 +141,11 @@ import qualified Foreign.Marshal.Utils as AllocUtil import qualified Foreign.Concurrent as FC import Foreign.Storable.Tuple ()-import Foreign.Storable (Storable, )+import Foreign.Storable (Storable, poke, peek, )+import Foreign.StablePtr+ (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, ) import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, )-import Foreign.Ptr (FunPtr, Ptr, )+import Foreign.Ptr (FunPtr, Ptr, castPtr, freeHaskellFunPtr, ) import Control.Exception (bracket, ) import qualified Synthesizer.LLVM.Debug.Storable as DebugSt@@ -159,44 +156,28 @@ (and, iterate, map, unzip, zip, zipWith, take, takeWhile, sequence_, ) -infixl 0 $<, $>, $*, $<#, $>#, $*#+infixl 0 $<, $>, $* -- infixr 0 $:* -- can be used together with $ -applyFst, ($<) :: T p (a,b) c -> Sig.T p a -> T p b c+applyFst, ($<) :: T p (a,b) c -> SigP.T p a -> T p b c applyFst = CausalClass.applyFst -applySnd, ($>) :: T p (a,b) c -> Sig.T p b -> T p a c+applySnd, ($>) :: T p (a,b) c -> SigP.T p b -> T p a c applySnd = CausalClass.applySnd {- These infix operators may become methods of a type class that can also have synthesizer-core:Causal.Process as instance. -}-($*) :: T p a b -> Sig.T p a -> Sig.T p b+($*) :: T p a b -> SigP.T p a -> SigP.T p b ($*) = apply ($<) = applyFst ($>) = applySnd -{- |-provide constant input in a comfortable way--}-($*#) ::- (Storable ah, MakeValueTuple ah, ValueTuple ah ~ a,- Memory.C a) =>- T p a b -> ah -> Sig.T p b-proc $*# x = proc $* (Sig.constant $# x) -($<#) ::- (Storable ah, MakeValueTuple ah, ValueTuple ah ~ a,- Memory.C a) =>- T p (a,b) c -> ah -> T p b c-proc $<# x = proc $< (Sig.constant $# x)--($>#) ::- (Storable bh, MakeValueTuple bh, ValueTuple bh ~ b,- Memory.C b) =>- T p (a,b) c -> bh -> T p a c-proc $># x = proc $> (Sig.constant $# x)+reparameterize :: Param.T q p -> T p a b -> T q a b+reparameterize p (Cons start stop next create delete) =+ Cons start stop next (create . Param.get p) delete mapAccumSimple ::@@ -210,7 +191,7 @@ replicateParallel :: (Undefined b, Phi b) =>- Param.T p Int -> Sig.T p b -> T p (b,b) b -> T p a b -> T p a b+ Param.T p Int -> SigP.T p b -> T p (b,b) b -> T p a b -> T p a b replicateParallel n z cum p = replicateControlled n (first p >>> cum) $> z @@ -357,17 +338,7 @@ {- |-You may also use '(+)'.--}-mix ::- (A.Additive a) =>- T p (a, a) a-mix =- zipWithSimple Frame.mix---{- |-You may also use '(+)' and a 'Sig.constant' signal or a number literal.+You may also use '(+)' and a 'SigP.constant' signal or a number literal. -} raise :: (A.Additive al, Storable a,@@ -378,22 +349,7 @@ {- |-You may also use '(*)'.--}-envelope ::- (A.PseudoRing a) =>- T p (a, a) a-envelope =- zipWithSimple Frame.amplifyMono--envelopeStereo ::- (A.PseudoRing a) =>- T p (a, Stereo.T a) (Stereo.T a)-envelopeStereo =- zipWithSimple Frame.amplifyStereo--{- |-You may also use '(*)' and a 'Sig.constant' signal or a number literal.+You may also use '(*)' and a 'SigP.constant' signal or a number literal. -} amplify :: (A.PseudoRing al, Storable a,@@ -413,7 +369,7 @@ mapLinear :: (IsArithmetic a, Storable a,- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, MakeValueTuple a, ValueTuple a ~ (Value a)) => Param.T p a -> Param.T p a -> T p (Value a) (Value a) mapLinear depth center =@@ -424,7 +380,7 @@ mapExponential :: (Trans.C a, IsFloating a, IsConst a, Storable a, SoV.TranscendentalConstant a,- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, MakeValueTuple a, ValueTuple a ~ (Value a)) => Param.T p a -> Param.T p a -> T p (Value a) (Value a) mapExponential depth center =@@ -452,65 +408,17 @@ Param.T p c -> T p a b -> T p a b-quantizeLift k- (Cons next start stop createIOContext deleteIOContext) =- Param.with k $ \getK valueK -> Cons- (\context a0 -> quantizeNext (flip next a0) valueK context)- (quantizeStart start)- (quantizeStop stop)- (quantizeCreate createIOContext getK)- (quantizeDelete deleteIOContext)+quantizeLift k causal =+ Causal.quantizeLift causal $< SigP.constant k -{- |-Compute the phases from phase distortions and frequencies.--It's like integrate but with wrap-around performed by @fraction@.-For FM synthesis we need also negative phase distortions,-thus we use 'SoV.addToPhase' which supports that.--}-osciCore, _osciCore, osciCoreSync ::- (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm,- SoV.Fraction t) =>- T p (Value t, Value t) (Value t)-_osciCore =- zipWithSimple SoV.addToPhase <<<- Arr.second- (mapAccumSimple- (\a s -> do- b <- SoV.incPhase a s- return (s,b))- (return A.zero))--osciCoreSync =- zipWithSimple SoV.addToPhase <<<- Arr.second- (mapAccumSimple- (\a s -> do- b <- SoV.incPhase a s- return (b,b))- (return A.zero))--osciCore =- zipWithSimple SoV.addToPhase <<<- Arr.second (loopZero (arr snd &&& zipWithSimple SoV.incPhase))-+-- for backwards compatibility osciSimple ::- (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,+ (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm, SoV.Fraction t) => (forall r. Value t -> CodeGenFunction r y) -> T p (Value t, Value t) y-osciSimple wave =- mapSimple wave <<< osciCore--shapeModOsci ::- (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,- SoV.Fraction t) =>- (forall r. c -> Value t -> CodeGenFunction r y) ->- T p (c, (Value t, Value t)) y-shapeModOsci wave =- zipWithSimple wave <<< Arr.second osciCore-+osciSimple = Causal.osci {- |@@ -553,10 +461,7 @@ Param.T p a -> T p al al delay1 initial = loop initial (arr swap) -delay1Zero :: (Memory.C a, A.Additive a) => T p a a-delay1Zero = loopZero (arr swap) - {- | Delay by a variable amount of samples. The momentum delay must be between @0@ and @maxTime@, inclusively.@@ -659,7 +564,7 @@ reverbEfficient rnd num gainRange timeRange = map (\n x -> flip A.scale x =<< A.fdiv A.one =<< LLVM.inttofp n)- (fmap (fromIntegral :: Int -> Word32) num)+ (Param.word32 num) <<< replicateControlledParam (\_p p -> first (comb (fmap fst p) (fmap snd p)) >>> mix)@@ -680,63 +585,6 @@ {- |-This allows to compute a chain of equal processes efficiently,-if all of these processes can be bundled in one vectorial process.-Applications are an allpass cascade or an FM operator cascade.--The function expects that the vectorial input process-works like parallel scalar processes.-The different pipeline stages may be controlled by different parameters,-but the structure of all pipeline stages must be equal.-Our function feeds the input of the pipelined process-to the zeroth element of the Vector.-The result of processing the i-th element (the i-th channel, so to speak)-is fed to the (i+1)-th element.-The (n-1)-th element of the vectorial process is emitted as output of pipelined process.--The pipeline necessarily introduces a delay of (n-1) values.-For simplification we extend this to n values delay.-If you need to combine the resulting signal from the pipeline-with another signal in a 'zip'-like way,-you may delay that signal with @pipeline id@.-The first input values in later stages of the pipeline-are initialized with zero.-If this is not appropriate for your application,-then we may add a more sensible initialization.--}-pipeline ::- (Vector.C v, a ~ Vector.Element v,- Class.Zero v, Memory.C v) =>- T p v v -> T p a a-pipeline = Causal.pipeline---{- |-Feeds a signal into a causal process while holding or skipping signal elements-according to the process input.-The skip happens after a value is passed from the fed signal.--@skip x $* 0@ repeats the first signal value in the output.-@skip x $* 1@ feeds the signal to the output as is.-@skip x $* 2@ feeds the signal to the output with double speed.--}-skip ::- (Undefined v, Phi v, Memory.C v) =>- Sig.T p v -> T p (Value Word32) v-skip (Sig.Cons next start stop createIOContext deleteIOContext) =- Cons- (\context n1 (yState0,n0) -> do- (y,state1) <-- MaybeCont.fromMaybe $ fmap snd $- MaybeCont.fixedLengthLoop n0 yState0 $- next context . snd- return (y, ((y,state1),n1)))- (withStart start $ \s -> return ((undefTuple, s), A.one))- (\context ((_y,state),_k) -> stop context state)- createIOContext- deleteIOContext--{- | Like 'skip' but does not require @Memory@ constraint on the result type. This way it can be used on a stream of ring buffer states. The downside is that the result is recomputed (from the previous state)@@ -748,20 +596,20 @@ like Signal.storableVectorLazy. -} _skipVolatile ::- Sig.T p v -> T p (Value Word32) v-_skipVolatile (Sig.Cons next start stop createIOContext deleteIOContext) =- Cons- (\context n state0 -> do- y <- fmap fst $ next context state0- state1 <-- MaybeCont.fromMaybe $ fmap snd $- MaybeCont.fixedLengthLoop n state0 $- fmap snd . next context- return (y, state1))- (withStart start return)- stop- createIOContext- deleteIOContext+ (Causal.C process, CausalClass.SignalOf process ~ signal) =>+ signal v -> process (Value Word32) v+_skipVolatile =+ Causal.alterSignal+ (\(Sig.Core next start stop) -> Causal.Core+ (\context n state0 -> do+ y <- fmap fst $ next context state0+ state1 <-+ MaybeCont.fromMaybe $ fmap snd $+ MaybeCont.fixedLengthLoop n state0 $+ fmap snd . next context+ return (y, state1))+ start+ stop) {- |@@ -777,104 +625,97 @@ frequencyModulationLinear :: (SoV.IntegerConstant a, IsFloating a, LLVM.CmpRet a, LLVM.CmpResult a ~ Bool, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am) =>- Sig.T p (Value a) -> T p (Value a) (Value a)-frequencyModulationLinear xs =- frequencyModulation Interpolation.linear (adjacentNodes02 xs)+ SigP.T p (Value a) -> T p (Value a) (Value a)+frequencyModulationLinear =+ Causal.frequencyModulation Interpolation.linear . SigP.adjacentNodes02 -frequencyModulation ::- (SoV.IntegerConstant a, IsFloating a, LLVM.CmpRet a, LLVM.CmpResult a ~ Bool,- Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- Undefined nodes, Phi nodes, Memory.C nodes) =>- (forall r. Value a -> nodes -> CodeGenFunction r v) ->- Sig.T p nodes -> T p (Value a) v-frequencyModulation ip- (Sig.Cons next start stop createIOContext deleteIOContext) =- Cons- (\context k yState0 -> do- ((nodes2,state2), ss2) <-- MaybeCont.fromBool $- C.whileLoop- (valueOf True, yState0)- (\(cont0, (_, ss0)) ->- LLVM.and cont0 =<< A.fcmp LLVM.FPOGE ss0 A.one)- (\(_,((_,state0), ss0)) ->- MaybeCont.toBool $ liftM2 (,)- (next context state0)- (MaybeCont.lift $ A.sub ss0 A.one)) - MaybeCont.lift $ do- y <- ip ss2 nodes2- ss3 <- A.add ss2 k- return (y, ((nodes2, state2), ss3)))- (withStart start $ \sa ->- return ((undefTuple, sa), A.fromInteger' 1))- (\context ((_y01,state),_ss) -> stop context state)- createIOContext- deleteIOContext+type Exporter f = f -> IO (FunPtr f) -adjacentNodes02 ::- (Memory.C a, Undefined a) =>- Sig.T p a -> Sig.T p (Interpolation.Nodes02 a)-adjacentNodes02 xs =- Sig.tail- (mapAccumSimple- (\new old -> return (Interpolation.Nodes02 old new, new))- (return undefTuple)- $*- xs)+foreign import ccall safe "wrapper" callbackCreate ::+ Exporter (Ptr lparam -> Ptr init -> IO (StablePtr ioContext)) -adjacentNodes13 ::- (MakeValueTuple ah, Storable ah, ValueTuple ah ~ a,- Memory.C a, Undefined a) =>- Param.T p ah -> Sig.T p a -> Sig.T p (Interpolation.Nodes13 a)-adjacentNodes13 yp0 xs =- Sig.tail $ Sig.tail- (mapAccum- (\() new (x0, x1, x2) ->- return (Interpolation.Nodes13 x0 x1 x2 new, (x1, x2, new)))- (\y0 -> return (undefTuple, undefTuple, Param.value yp0 y0))- (pure ()) yp0- $*- xs)+foreign import ccall safe "wrapper" callbackDelete ::+ Exporter (StablePtr ioContext -> IO ()) +stopAndDelete ::+ LLVM.Function (StablePtr ioContext -> IO ()) ->+ (context -> state -> CodeGenFunction r ()) ->+ Maybe.T ((context, state), Value (StablePtr ioContext)) ->+ CodeGenFunction r ()+stopAndDelete eraser stop mcsio =+ Maybe.for mcsio $ \(cs, io) -> do+ uncurry stop cs+ void $ LLVM.call eraser io +castBackStorablePtr ::+ (MakeValueTuple haskellValue, ValueTuple haskellValue ~ llvmValue,+ Memory.C llvmValue) =>+ Ptr (Memory.Struct (ValueTuple haskellValue)) -> Ptr haskellValue+castBackStorablePtr = castPtr++ {- | @trigger fill signal@ send @signal@ to the output and restart it whenever the Boolean process input is 'True'. Before the first occurrence of 'True'-and between instances of the signal the output is filled with the @fill@ value.+and between instances of the signal the output is filled with 'Maybe.nothing'. -Attention:-This function will crash if the input generator-uses fromStorableVectorLazy, piecewiseConstant or lazySize,-since these functions contain mutable references and in-place updates,-and thus they cannot read lazy Haskell data multiple times.+Every restart of the signal needs a call into Haskell code.+Thus it is certainly a good idea, not to trigger the signal too frequently. -}+{-+Are exceptions handled correctly?+-} trigger ::- (Storable a, MakeValueTuple a, ValueTuple a ~ al, C.Select al,- Memory.C al) =>- Param.T p a ->- Sig.T p al ->- T p (Value Bool) al-trigger fill (Sig.Cons next start stop createIOContext deleteIOContext) =- Param.with fill $ \getFill valueFill -> Cons- (\(param, f) b0 mcs0 -> MaybeCont.lift $ do- mcs1 <-- C.ifThen b0 mcs0 $- Maybe.for mcs0 (uncurry stop)- >>- fmap Maybe.just (start param)- mcas2 <-- Maybe.run mcs1 (return Maybe.nothing) $ \(c1,s1) ->- MaybeCont.toMaybe $ fmap ((,) c1) $ next c1 s1- a3 <- Maybe.select (fmap (fst.snd) mcas2) (valueFill f)- return (a3, fmap (mapSnd snd) mcas2))- (\pf -> return (pf, Maybe.nothing))- (\ _pf -> flip Maybe.for $ uncurry stop)+ (Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al,+ Undefined b, Phi b) =>+ (forall q. Param.T q p -> Param.T q a -> SigP.T q b) ->+ T p (Maybe.T al) (Maybe.T b)+trigger sig =+ triggerAux (sig (arr fst) (arr snd))++triggerAux ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al,+ Undefined b, Phi b) =>+ SigP.T (p,a) b ->+ T p (Maybe.T al) (Maybe.T b)+triggerAux (SigP.Cons next start stop createIOContext deleteIOContext) = Cons+ (\(creator, eraser) mx mcsio0 -> MaybeCont.lift $ do+ mcsio1 <-+ Maybe.run mx+ (return mcsio0)+ (\x ->+ stopAndDelete eraser stop mcsio0+ >>+ do+ param <- LLVM.alloca+ xPtr <- LLVM.alloca+ Memory.store x xPtr+ io <- LLVM.call creator param xPtr+ cs <- start =<< Memory.load param+ return $ Maybe.just (cs, io))+ mcasio2 <-+ Maybe.run mcsio1 (return Maybe.nothing) $ \((c1,s1), io1) ->+ MaybeCont.toMaybe $ fmap (flip (,) io1 . (,) c1) $ next c1 s1+ return (fmap (fst.snd.fst) mcasio2, fmap (mapFst (mapSnd snd)) mcasio2))+ (\ce -> return (ce, Maybe.nothing))+ (\(_creator, eraser) mcsio ->+ stopAndDelete eraser stop mcsio) (\p -> do- (context, param) <- createIOContext p- return (context, (param, getFill p)))- deleteIOContext+ creator <- callbackCreate $ \paramPtr xPtr -> do+ x <- peek (castBackStorablePtr xPtr)+ (context, param) <- createIOContext (p,x)+ poke (castBackStorablePtr paramPtr) param+ newStablePtr context+ eraser <- callbackDelete $ \contextPtr -> do+ deleteIOContext =<< deRefStablePtr contextPtr+ freeStablePtr contextPtr+ let ce = (creator, eraser)+ return (ce, ce))+ (\(creator, eraser) ->+ freeHaskellFunPtr creator >>+ freeHaskellFunPtr eraser) {- |@@ -884,7 +725,7 @@ (MakeValueTuple a, ValueTuple a ~ al, MakeValueTuple b, ValueTuple b ~ bl) => Param.T p a ->- (Param.T p b -> Sig.T p a) ->+ (Param.T p b -> SigP.T p a) -> T p (Value Bool, bl) al triggerParam fill sig = -}
src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs view
@@ -1,15 +1,26 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Synthesizer.LLVM.CausalParameterized.ProcessPacked where+module Synthesizer.LLVM.CausalParameterized.ProcessPacked (+ CausalS.pack,+ CausalS.packSmall,+ CausalS.unpack,+ raise,+ amplify,+ amplifyStereo,+ CausalS.osciCore,+ osciSimple,+ CausalS.shapeModOsci,+ delay1,+ differentiate,+ integrate,+ CausalS.arrayElement,+ ) where -import Synthesizer.LLVM.CausalParameterized.Process (T(Cons), )-import Synthesizer.LLVM.Parameterized.SignalPrivate (withStart, )+import Synthesizer.LLVM.CausalParameterized.ProcessPrivate (T, ) import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalS+import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Frame.SerialVector as Serial@@ -17,144 +28,33 @@ import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.MaybeContinuation as Maybe import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, undefTuple, )+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import qualified LLVM.Core as LLVM import LLVM.Core- (CodeGenFunction, Value, valueOf,- IsSized, IsArithmetic,- IsPrimitive, IsFirstClass, )+ (CodeGenFunction, Value,+ IsSized, IsArithmetic, IsPrimitive, ) -import qualified Types.Data.Bool as TypeBool-import qualified Types.Data.Num as TypeNum-import Types.Data.Ord ((:<:), )+import qualified Type.Data.Num.Decimal as TypeNum -import qualified Control.Monad.Trans.Class as MT-import qualified Control.Monad.Trans.State as MS import qualified Control.Category as Cat-import qualified Control.Arrow as Arr-import Control.Arrow ((<<<), ) import Data.Tuple.HT (swap, ) -import Data.Word (Word32, ) import Foreign.Storable (Storable, ) import NumericPrelude.Numeric import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, ) --{- |-Run a scalar process on packed data.-If the signal length is not divisible by the chunk size,-then the last chunk is dropped.--}-pack ::- (Serial.Read va, n ~ Serial.Size va, a ~ Serial.Element va,- Serial.C vb, n ~ Serial.Size vb, b ~ Serial.Element vb) =>- T p a b -> T p va vb-pack (Cons next start stop createIOContext deleteIOContext) = Cons- (\param a s -> do- r <- Maybe.lift $ Serial.readStart a- ((_,w2),(_,s2)) <-- Maybe.fromBool $- C.whileLoop- (valueOf True,- let w = undefTuple- in ((r,w),- (valueOf (fromIntegral $ Serial.sizeOfIterator w :: Word32), s)))- (\(cont,(_rw0,(i0,_s0))) ->- A.and cont =<<- A.cmp LLVM.CmpGT i0 A.zero)- (\(_,((r0,w0),(i0,s0))) -> Maybe.toBool $ do- (ai,r1) <- Maybe.lift $ Serial.readNext r0- (bi,s1) <- next param ai s0- Maybe.lift $ do- w1 <- Serial.writeNext bi w0- i1 <- A.dec i0- return ((r1,w1),(i1,s1)))- b <- Maybe.lift $ Serial.writeStop w2- return (b, s2))- start- stop- createIOContext- deleteIOContext--{- |-Like 'pack' but duplicates the code for the scalar process.-That is, for vectors of size n,-the code for the scalar causal process will be written n times.-This is efficient only for simple input processes.--}-packSmall ::- (Serial.Read va, n ~ Serial.Size va, a ~ Serial.Element va,- Serial.C vb, n ~ Serial.Size vb, b ~ Serial.Element vb) =>- T p a b -> T p va vb-packSmall (Cons next start stop createIOContext deleteIOContext) = Cons- (\param a ->- MS.runStateT $- (MT.lift . Maybe.lift . Serial.assemble)- =<<- mapM (MS.StateT . next param)- =<<- (MT.lift $ Maybe.lift $ Serial.extractAll a))- start- stop- createIOContext- deleteIOContext---{- |-Run a packed process on scalar data.-If the signal length is not divisible by the chunk size,-then the last chunk is dropped.-In order to stay causal, we have to delay the output by @n@ samples.--}-unpack ::- (Serial.Zero va, n ~ Serial.Size va, a ~ Serial.Element va,- Serial.Read vb, n ~ Serial.Size vb, b ~ Serial.Element vb,- Memory.C (Serial.WriteIt va), Memory.C (Serial.ReadIt vb),- Memory.C va,- Memory.C vb) =>- T p va vb -> T p a b-unpack (Cons next start stop createIOContext deleteIOContext) = Cons- (\param ai ((w0,r0),(i0,s0)) -> do- endOfVector <- Maybe.lift $ A.cmp LLVM.CmpEQ i0 A.zero- ((w2,r2),(i2,s2)) <-- Maybe.fromBool $- C.ifThen endOfVector (valueOf True, ((w0,r0),(i0,s0))) $ do- a0 <- Serial.writeStop w0- (cont1, (b1,s1)) <- Maybe.toBool $ next param a0 s0- r1 <- Serial.readStart b1- w1 <- Serial.writeStart- return (cont1,- ((w1, r1),- (valueOf $ fromIntegral $ Serial.size a0, s1)))- Maybe.lift $ do- w3 <- Serial.writeNext ai w2- (bi,r3) <- Serial.readNext r2- i3 <- A.dec i2- return (bi, ((w3,r3),(i3,s2))))- (withStart start $ \s -> do- w <- Serial.writeZero- return ((w, Class.undefTuple), (valueOf (0::Word32), s)))- (\context (_wr,(_i,state)) -> stop context state)- createIOContext- deleteIOContext-- raise :: (Storable a, IsArithmetic a, MakeValueTuple a, ValueTuple a ~ (Value a), IsPrimitive a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- TypeNum.PositiveT n) =>+ TypeNum.Positive n) => Param.T p a -> T p (Serial.Value n a) (Serial.Value n a) raise =@@ -166,7 +66,7 @@ MakeValueTuple a, ValueTuple a ~ (Value a), IsPrimitive a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- TypeNum.PositiveT n) =>+ TypeNum.Positive n) => Param.T p a -> T p (Serial.Value n a) (Serial.Value n a) amplify =@@ -178,7 +78,7 @@ MakeValueTuple a, ValueTuple a ~ (Value a), IsPrimitive a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- TypeNum.PositiveT n) =>+ TypeNum.Positive n) => Param.T p a -> T p (Stereo.T (Serial.Value n a)) (Stereo.T (Serial.Value n a)) amplifyStereo =@@ -186,38 +86,15 @@ (\x y -> Serial.upsample x >>= flip Frame.amplifyStereo y) -osciCore ::- (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,- Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,- TypeNum.PositiveT n) =>- T p (Serial.Value n t, Serial.Value n t) (Serial.Value n t)-osciCore =- CausalP.zipWithSimple A.addToPhase <<<- Arr.second- (CausalP.mapAccumSimple- (\a phase0 -> do- (phase1,b1) <- Serial.cumulate phase0 a- phase2 <- A.signedFraction phase1- return (b1,phase2))- (return A.zero))-+-- for backwards compatibility osciSimple ::- (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,+ (Causal.C process,+ Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,- TypeNum.PositiveT n) =>+ TypeNum.Positive n) => (forall r. Serial.Value n t -> CodeGenFunction r y) ->- T p (Serial.Value n t, Serial.Value n t) y-osciSimple wave =- CausalP.mapSimple wave <<< osciCore--shapeModOsci ::- (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,- Vector.Real t, SoV.Fraction t, LLVM.IsFloating t,- TypeNum.PositiveT n) =>- (forall r. c -> Serial.Value n t -> CodeGenFunction r y) ->- T p (c, (Serial.Value n t, Serial.Value n t)) y-shapeModOsci wave =- CausalP.zipWithSimple wave <<< Arr.second osciCore+ process (Serial.Value n t, Serial.Value n t) y+osciSimple = CausalS.osci delay1 ::@@ -228,7 +105,7 @@ Param.T p a -> T p va va delay1 initial = CausalP.loop initial $- CausalP.mapSimple (fmap swap . uncurry Serial.shiftUp . swap)+ Causal.map (fmap swap . uncurry Serial.shiftUp . swap) differentiate :: (Serial.C va, n ~ Serial.Size va, al ~ Serial.Element va,@@ -243,7 +120,7 @@ integrate :: (Storable a, MakeValueTuple a, ValueTuple a ~ Value a, Vector.Arithmetic a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- TypeNum.PositiveT n) =>+ TypeNum.Positive n) => Param.T p a -> T p (Serial.Value n a) (Serial.Value n a) integrate =@@ -253,14 +130,3 @@ return (b,acc1)) return (return ())---arrayElement ::- (IsFirstClass a, LLVM.Value a ~ Serial.Element v, Serial.C v,- LLVM.GetValue (LLVM.Array dim a) index,- LLVM.ValueType (LLVM.Array dim a) index ~ a,- TypeNum.NaturalT index, TypeNum.NaturalT dim,- (index :<: dim) ~ TypeBool.True) =>- index -> T p (Value (LLVM.Array dim a)) v-arrayElement i =- CausalP.mapSimple Serial.upsample <<< CausalP.arrayElement i
src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs view
@@ -9,8 +9,10 @@ import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Causal.Process as Causal import Synthesizer.LLVM.Causal.ProcessPrivate (loopNext, )+import Synthesizer.LLVM.Causal.Process (mapProc, zipProcWith, ) import qualified Synthesizer.Causal.Class as CausalClass+import qualified Synthesizer.Causal.Utility as ArrowUtil import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Arithmetic as A@@ -22,7 +24,7 @@ import LLVM.Util.Loop (Phi, ) import LLVM.Core (CodeGenFunction, Value, valueOf, ) -import Types.Data.Num (d1, )+import Type.Data.Num.Decimal (d1, ) import qualified Control.Monad.HT as M import qualified Control.Arrow as Arr@@ -90,13 +92,14 @@ simple next start = simple (\() -> next) (\() -> fmap ((,) ()) start) (pure ()) - loopConst init (Cons next start stop createIOContext deleteIOContext) =- Cons- (loopNext next)- (fmap (mapSnd ((,) init)) . start)- (loopStop stop)- createIOContext- deleteIOContext+ alter f (Cons next0 start0 stop0 create delete) =+ case f (Causal.Core next0 return id) of+ Causal.Core next1 start1 stop1 ->+ Cons+ next1+ (Sig.withStart start0 start1)+ (\c -> stop0 c . stop1)+ create delete replicateControlled n = replicateControlled $ pure n @@ -257,20 +260,6 @@ composeDelete = Sig.combineDelete -first :: T p b c -> T p (b, d) (c, d)-first (Cons next start stop createIOContext deleteIOContext) = Cons- (firstNext next) start stop- createIOContext deleteIOContext--firstNext ::- Monad m =>- (context -> a -> s -> m (b, s)) ->- context -> (a, c) -> s -> m ((b, c), s)-firstNext next context (b,d) sa0 = do- (c,sa1) <- next context b sa0- return ((c,d), sa1)-- {- | serial replication @@ -404,45 +393,45 @@ instance Arr.Arrow (T p) where arr f = mapSimple (return . f)- first = first+ first = Causal.first instance Functor (T p a) where- fmap = (^<<)+ fmap = ArrowUtil.map instance Applicative (T p a) where- pure x = Arr.arr (const x)- f <*> x = uncurry ($) ^<< f&&&x+ pure = ArrowUtil.pure+ (<*>) = ArrowUtil.apply instance (A.Additive b) => Additive.C (T p a b) where zero = pure A.zero- negate x = mapSimple A.neg <<< x- x + y = zipWithSimple A.add <<< x&&&y- x - y = zipWithSimple A.sub <<< x&&&y+ negate = mapProc A.neg+ (+) = zipProcWith A.add+ (-) = zipProcWith A.sub instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T p a b) where one = pure A.one fromInteger n = pure (A.fromInteger' n)- x * y = zipWithSimple A.mul <<< x&&&y+ (*) = zipProcWith A.mul instance (A.Field b, A.RationalConstant b) => Field.C (T p a b) where fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)- x / y = zipWithSimple A.fdiv <<< x&&&y+ (/) = zipProcWith A.fdiv instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => P.Num (T p a b) where fromInteger n = pure (A.fromInteger' n)- negate x = mapSimple A.neg <<< x- x + y = zipWithSimple A.add <<< x&&&y- x - y = zipWithSimple A.sub <<< x&&&y- x * y = zipWithSimple A.mul <<< x&&&y- abs x = mapSimple A.abs <<< x- signum x = mapSimple A.signum <<< x+ negate = mapProc A.neg+ (+) = zipProcWith A.add+ (-) = zipProcWith A.sub+ (*) = zipProcWith A.mul+ abs = mapProc A.abs+ signum = mapProc A.signum instance (A.Field b, A.Real b, A.RationalConstant b) => P.Fractional (T p a b) where fromRational x = pure (A.fromRational' x)- x / y = zipWithSimple A.fdiv <<< x&&&y+ (/) = zipProcWith A.fdiv {- |@@ -493,7 +482,7 @@ takeWhile (const $ A.cmp LLVM.CmpLT A.zero . fst) (return ()) <<< feedFst (Sig.iterate (const A.dec) (return ())- ((fromIntegral :: Int -> Word32) . max 0 ^<< len))+ (Param.word32 $ max 0 ^<< len)) {- |
src/Synthesizer/LLVM/Complex.hs view
@@ -17,7 +17,7 @@ import LLVM.Core (Value, ConstValue, IsConst, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum import Control.Applicative (liftA2, )
src/Synthesizer/LLVM/ConstantPiece.hs view
@@ -8,6 +8,7 @@ module Synthesizer.LLVM.ConstantPiece where import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigP+import qualified Synthesizer.LLVM.Simple.Signal as Sig import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt@@ -28,7 +29,7 @@ import LLVM.Core (Value, valueOf, ) import qualified LLVM.Core as LLVM -import Types.Data.Num (d0, d1, )+import Type.Data.Num.Decimal (d0, d1, ) import Data.Word (Word32, ) import Foreign.Storable.Tuple ()@@ -77,11 +78,11 @@ flatten ::- (Memory.C value) =>- SigP.T p (T value) ->- SigP.T p value-flatten (SigP.Cons next start stop createIOContext deleteIOContext) =- SigP.Cons+ (Sig.C signal, Memory.C value) =>+ signal (T value) ->+ signal value+flatten = Sig.alter (\(Sig.Core next start stop) ->+ Sig.Core (\context state0 -> do (Cons length1 y1, s1) <- Maybe.fromBool $@@ -92,9 +93,8 @@ Maybe.toBool $ next context s) length2 <- Maybe.lift (A.dec length1) return (y1, (Cons length2 y1, s1)))- (SigP.withStart start (return . ((,) (Cons A.zero undefTuple))))- (\context (_, state) -> stop context state)- createIOContext deleteIOContext+ (fmap ((,) (Cons A.zero undefTuple)) . start)+ (stop . snd)) piecewiseConstant ::
src/Synthesizer/LLVM/Debug/Storable.hs view
@@ -3,7 +3,9 @@ import qualified Synthesizer.LLVM.Debug.Counter as Counter -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Base.Proxy (Proxy)+ import qualified LLVM.Core as LLVM import LLVM.Core (Array, ConstValue, constOf, ) @@ -60,7 +62,7 @@ withConstArray :: Storable a => a ->- (forall n. TypeNum.NaturalT n => ConstValue (Array n ArrayElem) -> b) ->+ (forall n. TypeNum.Natural n => ConstValue (Array n ArrayElem) -> b) -> IO b withConstArray a f = Marshal.with a $ \ptr -> do@@ -71,11 +73,11 @@ :: IO [ArrayElem] return $ fromMaybe (error "Debug.Storable.withConstArray: length must always be non-negative") $- TypeNum.reifyNaturalD (fromIntegral (length content))+ TypeNum.reifyNatural (fromIntegral (length content)) (\n -> let makeArray ::- TypeNum.NaturalT n =>- n -> [ConstValue ArrayElem] ->+ TypeNum.Natural n =>+ Proxy n -> [ConstValue ArrayElem] -> ConstValue (Array n ArrayElem) makeArray _ = LLVM.constArray in f (makeArray n (map constOf content)))
src/Synthesizer/LLVM/EventIterator.hs view
@@ -9,13 +9,12 @@ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class -import Data.Word (Word32, ) import Foreign.Storable (Storable, poke, )-import Foreign.Ptr (Ptr, castPtr, )--import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, )-import Foreign.Ptr (FunPtr, )+import Foreign.StablePtr+ (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, )+import Foreign.Ptr (FunPtr, Ptr, castPtr, ) import Data.IORef (IORef, newIORef, readIORef, writeIORef, )+import Data.Word (Word32, ) import Control.Monad ((<=<), )
src/Synthesizer/LLVM/Execution.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} module Synthesizer.LLVM.Execution where +import qualified LLVM.Extra.Execution as Exec import qualified LLVM.ExecutionEngine as EE import qualified LLVM.Util.Optimize as Opt import qualified LLVM.Core as LLVM@@ -8,7 +9,7 @@ import Foreign.Ptr (FunPtr, ) import qualified Control.Monad.Trans.Reader as R-import Control.Monad (liftM2, liftM3, )+import Control.Monad (liftM2, ) import qualified Data.IORef as IORef import qualified System.Unsafe as Unsafe@@ -18,30 +19,6 @@ type Importer f = FunPtr f -> f -class Compile externFunction where- type LLVMFunction externFunction :: *- compile :: LLVMFunction externFunction -> EE.EngineAccess externFunction--instance Compile (FunPtr f) where- type LLVMFunction (FunPtr f) = (LLVM.Function f)- compile = EE.getPointerToFunction--instance (Compile fa, Compile fb) => Compile (fa,fb) where- type LLVMFunction (fa,fb) = (LLVMFunction fa, LLVMFunction fb)- compile (fa,fb) =- liftM2 (,)- (compile fa)- (compile fb)--instance (Compile fa, Compile fb, Compile fc) => Compile (fa,fb,fc) where- type LLVMFunction (fa,fb,fc) = (LLVMFunction fa, LLVMFunction fb, LLVMFunction fc)- compile (fa,fb,fc) =- liftM3 (,,)- (compile fa)- (compile fb)- (compile fc)-- data BitCodeCnt = BitCodeCnt {- |@@ -81,11 +58,11 @@ -- this compiles once and is much faster than runFunction compileModule ::- (Compile externFunction) =>- LLVM.CodeGenModule (LLVMFunction externFunction) ->+ (Exec.Compile externFunction) =>+ LLVM.CodeGenModule (Exec.LLVMFunction externFunction) -> IO externFunction compileModule =- assembleModule compile+ assembleModule Exec.compile runFunction :: (EE.Translatable f) =>
src/Synthesizer/LLVM/Filter/Allpass.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveTraversable #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Filter.Allpass (@@ -14,7 +15,6 @@ causalPacked, cascadePacked, phaserPacked, causalP, cascadeP, phaserP,- cascadePipelineP, phaserPipelineP, causalPackedP, cascadePackedP, phaserPackedP, ) where @@ -32,7 +32,12 @@ import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Simple.Value as Value +import qualified LLVM.Extra.Multi.Vector.Memory as MultiVectorMemory+import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory+import qualified LLVM.Extra.Multi.Vector as MultiVector+import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Scalar as Scalar import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A@@ -42,7 +47,8 @@ import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Base.Proxy (Proxy(Proxy), ) import Foreign.Storable (Storable, ) @@ -51,6 +57,7 @@ import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav import Control.Arrow ((<<<), (^<<), (<<^), (&&&), arr, first, second, )+import Data.Tuple.HT (mapPair, ) import qualified Algebra.Transcendental as Trans -- import qualified Algebra.Field as Field@@ -91,7 +98,81 @@ type ValueTuple (Parameter a) = Parameter (Class.ValueTuple a) valueTupleOf = Class.valueTupleOfFunctor +instance (MultiValue.C a) => MultiValue.C (Allpass.Parameter a) where+ type Repr f (Allpass.Parameter a) = Allpass.Parameter (MultiValue.Repr f a)+ cons = paramFromPlainValue . MultiValue.cons . Allpass.getParameter + undef = paramFromPlainValue MultiValue.undef+ zero = paramFromPlainValue MultiValue.zero++ phis bb =+ fmap paramFromPlainValue .+ MultiValue.phis bb .+ plainFromParamValue+ addPhis bb a b =+ MultiValue.addPhis bb+ (plainFromParamValue a)+ (plainFromParamValue b)++instance (MultiVector.C a) => MultiVector.C (Allpass.Parameter a) where+ undef = paramFromPlainVector MultiVector.undef+ zero = paramFromPlainVector MultiVector.zero++ phis bb =+ fmap paramFromPlainVector .+ MultiVector.phis bb .+ plainFromParamVector+ addPhis bb a b =+ MultiVector.addPhis bb+ (plainFromParamVector a)+ (plainFromParamVector b)++ shuffleMatch is a =+ fmap paramFromPlainVector $+ MultiVector.shuffleMatch is $+ plainFromParamVector a+ extract i v =+ fmap paramFromPlainValue $+ MultiVector.extract i $+ plainFromParamVector v+ insert i a v =+ fmap paramFromPlainVector $+ MultiVector.insert i (plainFromParamValue a) $+ plainFromParamVector v++paramFromPlainVector ::+ MultiVector.T n a ->+ MultiVector.T n (Allpass.Parameter a)+paramFromPlainVector =+ MultiVector.lift1 Allpass.Parameter++plainFromParamVector ::+ MultiVector.T n (Allpass.Parameter a) ->+ MultiVector.T n a+plainFromParamVector =+ MultiVector.lift1 Allpass.getParameter++paramFromPlainValue ::+ MultiValue.T a ->+ MultiValue.T (Allpass.Parameter a)+paramFromPlainValue =+ MultiValue.lift1 Allpass.Parameter++plainFromParamValue ::+ MultiValue.T (Allpass.Parameter a) ->+ MultiValue.T a+plainFromParamValue =+ MultiValue.lift1 Allpass.getParameter+++instance (MultiVectorMemory.C n a) => MultiVectorMemory.C n (Allpass.Parameter a) where+ type Struct n (Allpass.Parameter a) = MultiVectorMemory.Struct n a+ load = fmap paramFromPlainVector . MultiVectorMemory.load+ store = MultiVectorMemory.store . plainFromParamVector+ decompose = fmap paramFromPlainVector . MultiVectorMemory.decompose+ compose = MultiVectorMemory.compose . plainFromParamVector++ instance (Value.Flatten a) => Value.Flatten (Parameter a) where type Registers (Parameter a) = Parameter (Value.Registers a) flattenCode = Value.flattenCodeTraversable@@ -145,7 +226,75 @@ type ValueTuple (CascadeParameter n a) = CascadeParameter n (Class.ValueTuple a) valueTupleOf = Class.valueTupleOfFunctor +instance (MultiValue.C a) => MultiValue.C (CascadeParameter n a) where+ type Repr f (CascadeParameter n a) = MultiValue.Repr f (Allpass.Parameter a)+ cons (CascadeParameter a) = cascadeFromParamValue $ MultiValue.cons a + undef = cascadeFromParamValue MultiValue.undef+ zero = cascadeFromParamValue MultiValue.zero++ phis bb =+ fmap cascadeFromParamValue .+ MultiValue.phis bb .+ paramFromCascadeValue+ addPhis bb a b =+ MultiValue.addPhis bb+ (paramFromCascadeValue a)+ (paramFromCascadeValue b)++instance (MultiVector.C a) => MultiVector.C (CascadeParameter n a) where+ undef = cascadeFromParamVector MultiVector.undef+ zero = cascadeFromParamVector MultiVector.zero++ phis bb =+ fmap cascadeFromParamVector .+ MultiVector.phis bb .+ paramFromCascadeVector+ addPhis bb a b =+ MultiVector.addPhis bb+ (paramFromCascadeVector a)+ (paramFromCascadeVector b)++ shuffleMatch is a =+ fmap cascadeFromParamVector $+ MultiVector.shuffleMatch is $+ paramFromCascadeVector a+ extract i v =+ fmap cascadeFromParamValue $+ MultiVector.extract i $+ paramFromCascadeVector v+ insert i a v =+ fmap cascadeFromParamVector $+ MultiVector.insert i (paramFromCascadeValue a) $+ paramFromCascadeVector v++cascadeFromParamVector ::+ MultiVector.T n (Allpass.Parameter a) ->+ MultiVector.T n (CascadeParameter m a)+cascadeFromParamVector = MultiVector.lift1 id++paramFromCascadeVector ::+ MultiVector.T n (CascadeParameter m a) ->+ MultiVector.T n (Allpass.Parameter a)+paramFromCascadeVector = MultiVector.lift1 id++cascadeFromParamValue ::+ MultiValue.T (Allpass.Parameter a) ->+ MultiValue.T (CascadeParameter m a)+cascadeFromParamValue = MultiValue.lift1 id++paramFromCascadeValue ::+ MultiValue.T (CascadeParameter m a) ->+ MultiValue.T (Allpass.Parameter a)+paramFromCascadeValue = MultiValue.lift1 id++instance (MultiVectorMemory.C n a) => MultiVectorMemory.C n (CascadeParameter n a) where+ type Struct n (CascadeParameter n a) = MultiVectorMemory.Struct n (Allpass.Parameter a)+ load = fmap cascadeFromParamVector . MultiVectorMemory.load+ store = MultiVectorMemory.store . paramFromCascadeVector+ decompose = fmap cascadeFromParamVector . MultiVectorMemory.decompose+ compose = MultiVectorMemory.compose . paramFromCascadeVector+ instance (Value.Flatten a) => Value.Flatten (CascadeParameter n a) where type Registers (CascadeParameter n a) = CascadeParameter n (Value.Registers a) flattenCode = Value.flattenCodeTraversable@@ -167,18 +316,18 @@ flangerParameter ::- (A.Transcendental a, A.RationalConstant a, TypeNum.NaturalT n) =>- n -> a ->+ (A.Transcendental a, A.RationalConstant a, TypeNum.Natural n) =>+ Proxy n -> a -> CodeGenFunction r (CascadeParameter n a) flangerParameter order = Value.unlift1 (flangerParameterPlain order) flangerParameterPlain ::- (Trans.C a, TypeNum.NaturalT n) =>- n -> a -> CascadeParameter n a+ (Trans.C a, TypeNum.Natural n) =>+ Proxy n -> a -> CascadeParameter n a flangerParameterPlain order freq = CascadeParameter $- Allpass.flangerParameter (TypeNum.fromIntegerT order) freq+ Allpass.flangerParameter (TypeNum.integralFromProxy order) freq modifier ::@@ -196,7 +345,7 @@ -} causal :: (Causal.C process,- A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>+ A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) => process (Parameter a, v) v causal = Causal.fromModifier modifier@@ -204,94 +353,156 @@ replicateStage :: (Causal.C process,- TypeNum.NaturalT n, Phi b, Undefined b) =>- n ->+ TypeNum.Natural n, Phi b, Undefined b) =>+ Proxy n -> process (Parameter a, b) b -> process (CascadeParameter n a, b) b replicateStage order stg = Causal.replicateControlled- (TypeNum.fromIntegerT order)+ (TypeNum.integralFromProxy order) (stg <<< first (arr (\(CascadeParameter p) -> p))) cascade :: (Causal.C process, A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,- TypeNum.NaturalT n) =>+ TypeNum.Natural n) => process (CascadeParameter n a, v) v cascade =- replicateStage undefined causal+ replicateStage Proxy causal -half ::+halfVector :: (Causal.C process, A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v) => process v v-half = CausalV.map (Value.fromRational' 0.5 *>)+halfVector = CausalV.map (Value.fromRational' 0.5 *>) phaser :: (Causal.C process, A.RationalConstant a, A.RationalConstant v, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,- TypeNum.NaturalT n) =>+ TypeNum.Natural n) => process (CascadeParameter n a, v) v phaser = Causal.mix <<< cascade &&& arr snd <<<- second half+ second halfVector +paramFromCascadeParam ::+ MultiValue.T (CascadeParameter n a) ->+ Allpass.Parameter (MultiValue.T a)+paramFromCascadeParam (MultiValue.Cons a) =+ fmap MultiValue.Cons a+ {- It shouldn't be too hard to use vector operations for the code we generate, but LLVM-2.6 does not yet do it. -} stage :: (Causal.C process,- Vector.Canonical n a, Vector.Construct n a ~ v,- a ~ A.Scalar a, A.PseudoModule a, A.IntegerConstant a, Memory.C a) =>- n ->- process- (CascadeParameter n v, v)- (CascadeParameter n v, v)+ TypeNum.Positive n, MultiVector.C a,+ MultiVector.T n (CascadeParameter n a, a) ~ v,+ MultiValue.PseudoRing a, MultiValue.IntegerConstant a,+ MultiValueMemory.C a) =>+ Proxy n -> process v v stage _ =- Causal.vectorize+ Causal.vectorize $+ uncurry MultiValue.zip+ ^<< (arr fst &&&- (Causal.fromModifier modifier <<<- first (arr (\(CascadeParameter p) -> p))))+ (Scalar.decons+ ^<<+ causal+ <<^+ (\(p, v) ->+ (fmap Scalar.Cons $ paramFromCascadeParam p, Scalar.Cons v))))+ <<^+ MultiValue.unzip withSize ::- (n -> process (CascadeParameter n a, b) c) ->- process (CascadeParameter n a, b) c-withSize f = f undefined+ (Proxy n -> process (MultiValue.T (CascadeParameter n a), b) c) ->+ process (MultiValue.T (CascadeParameter n a), b) c+withSize f = f Proxy {- |-Fast implementation of 'cascadeP' using vector instructions.+Fast implementation of 'cascade' using vector instructions. However, there must be at least one pipeline stage, primitive element types and we get a delay by the number of pipeline stages. -} cascadePipeline :: (Causal.C process,- Vector.Canonical n a, Vector.Construct n a ~ v,- a ~ A.Scalar a, A.PseudoModule a, A.IntegerConstant a, Memory.C a,- A.Additive v, Memory.C v) =>- process (CascadeParameter n a, a) a+ TypeNum.Positive n, MultiVector.C a,+ MultiValue.Repr LLVM.Value a ~ ar,+ MultiValue.PseudoRing a, MultiValue.IntegerConstant a,+ MultiValueMemory.C a, MultiVectorMemory.C n a) =>+ process+ (MultiValue.T (CascadeParameter n a), MultiValue.T a)+ (MultiValue.T a) cascadePipeline = withSize $ \order ->- snd ^<< Causal.pipeline (stage order)+ MultiValue.snd+ ^<<+ Causal.pipeline (stage order)+ <<^+ uncurry MultiValue.zip vectorId ::- (Causal.C process, Vector.Canonical n a) =>- n -> process (Vector.Construct n a) (Vector.Construct n a)+ (Causal.C process) =>+ Proxy n -> process (MultiVector.T n a) (MultiVector.T n a) vectorId _ = Cat.id +half ::+ (Causal.C process, A.RationalConstant a, A.PseudoRing a) =>+ process a a+half = CausalV.map (Value.fromRational' 0.5 *)+++multiValue ::+ (MultiValue.Repr LLVM.Value a ~ LLVM.Value a) =>+ LLVM.Value a -> MultiValue.T a+multiValue = MultiValue.Cons++unmultiValue ::+ (MultiValue.Repr LLVM.Value a ~ LLVM.Value a) =>+ MultiValue.T a -> LLVM.Value a+unmultiValue (MultiValue.Cons a) = a++multiCascadeParam ::+ (MultiValue.Repr LLVM.Value a ~ LLVM.Value a) =>+ CascadeParameter n (LLVM.Value a) ->+ MultiValue.T (CascadeParameter n a)+multiCascadeParam (CascadeParameter a) =+ MultiValue.Cons a+ phaserPipeline :: (Causal.C process,- Vector.Canonical n a, Vector.Construct n a ~ v,- a ~ A.Scalar a, A.PseudoModule a, A.RationalConstant a, Memory.C a,- A.Additive v, Memory.C v) =>- process (CascadeParameter n a, a) a-phaserPipeline = withSize $ \order ->+ TypeNum.Positive n,+ MultiValue.PseudoRing a, MultiValue.RationalConstant a,+ MultiValueMemory.C a, MultiVectorMemory.C n a,+ MultiValue.Repr LLVM.Value a ~ LLVM.Value a) =>+ process+ (CascadeParameter n (LLVM.Value a), LLVM.Value a)+ (LLVM.Value a)+phaserPipeline =+ unmultiValue+ ^<<+ phaserPipelineMulti+ <<^+ mapPair (multiCascadeParam, multiValue)+++phaserPipelineMulti ::+ (Causal.C process,+ TypeNum.Positive n,+ MultiValue.PseudoRing a, MultiValue.RationalConstant a,+ MultiValueMemory.C a, MultiVectorMemory.C n a) =>+ process+ (MultiValue.T (CascadeParameter n a), MultiValue.T a)+ (MultiValue.T a)+phaserPipelineMulti = withSize $ \order -> Causal.mix <<< cascadePipeline &&& (Causal.pipeline (vectorId order) <<^ snd) <<<--- (Causal.delay (const zero) (const $ TypeNum.fromIntegerT order) <<^ snd) <<<+-- (Causal.delay (const zero) (const $ TypeNum.integralFromProxy order) <<^ snd) <<< second half @@ -322,13 +533,13 @@ cascadePacked, phaserPacked :: (Causal.C process,- TypeNum.NaturalT n,+ TypeNum.Natural n, Serial.C v, Serial.Element v ~ a, A.PseudoRing a, A.IntegerConstant a, Memory.C a, A.PseudoRing v, A.RationalConstant v) => process (CascadeParameter n a, v) v cascadePacked =- replicateStage undefined causalPacked+ replicateStage Proxy causalPacked phaserPacked = Causal.mix <<<@@ -346,33 +557,18 @@ cascadeP :: (A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,- TypeNum.NaturalT n) =>+ TypeNum.Natural n) => CausalP.T p (CascadeParameter n a, v) v cascadeP = cascade phaserP :: (A.RationalConstant a, A.RationalConstant v, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,- TypeNum.NaturalT n) =>+ TypeNum.Natural n) => CausalP.T p (CascadeParameter n a, v) v phaserP = phaser -cascadePipelineP ::- (Vector.Canonical n a, Vector.Construct n a ~ v,- a ~ A.Scalar a, A.PseudoModule a, A.IntegerConstant a, Memory.C a,- A.Additive v, Memory.C v) =>- CausalP.T p (CascadeParameter n a, a) a-cascadePipelineP = cascadePipeline--phaserPipelineP ::- (Vector.Canonical n a, Vector.Construct n a ~ v,- a ~ A.Scalar a, A.PseudoModule a, A.RationalConstant a, Memory.C a,- A.Additive v, Memory.C v) =>- CausalP.T p (CascadeParameter n a, a) a-phaserPipelineP = phaserPipeline-- causalPackedP :: (Serial.C v, Serial.Element v ~ a, Memory.C a, A.IntegerConstant a,@@ -381,7 +577,7 @@ causalPackedP = causalPacked cascadePackedP, phaserPackedP ::- (TypeNum.NaturalT n,+ (TypeNum.Natural n, Serial.C v, Serial.Element v ~ a, A.PseudoRing a, A.IntegerConstant a, Memory.C a, A.PseudoRing v, A.RationalConstant v) =>@@ -392,8 +588,6 @@ {-# DEPRECATED causalP "use 'causal' instead" #-} {-# DEPRECATED cascadeP "use 'cascade' instead" #-} {-# DEPRECATED phaserP "use 'phaser' instead" #-}-{-# DEPRECATED cascadePipelineP "use 'cascadePipeline' instead" #-}-{-# DEPRECATED phaserPipelineP "use 'phaserPipeline' instead" #-} {-# DEPRECATED causalPackedP "use 'causalPacked' instead" #-} {-# DEPRECATED cascadePackedP "use 'cascadePacked' instead" #-} {-# DEPRECATED phaserPackedP "use 'phaserPacked' instead" #-}
src/Synthesizer/LLVM/Filter/Butterworth.hs view
@@ -28,8 +28,9 @@ CodeGenFunction, ) import Data.Word (Word32, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num.Ops ((:*:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal.Number ((:*:), )+import Type.Base.Proxy (Proxy, ) import qualified Algebra.Transcendental as Trans -- import qualified Algebra.Field as Field@@ -42,28 +43,25 @@ parameter, parameterMalloc, _parameterAlloca :: (Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,- TypeNum.NaturalT n,- TypeNum.PositiveT (n :*: SizeOf a),+ TypeNum.Natural n,+ TypeNum.Positive (n :*: SizeOf a), IsSized (Cascade.ParameterStruct n a)) =>- n -> Passband -> Value a -> Value a ->+ Proxy n -> Passband -> Value a -> Value a -> CodeGenFunction r (Cascade.ParameterValue n a) parameter = parameterMalloc parameterMalloc n kind ratio freq = do- let order = 2 * TypeNum.fromIntegerT n+ let order = 2 * TypeNum.integralFromProxy n partialRatio <- Value.unlift1 (Butterworth.partialRatio order) ratio let sines =- (flip const :: n -> LLVM.Value (LLVM.Array n a)- -> LLVM.Value (LLVM.Array n a)) n $- LLVM.value $- LLVM.constArray $+ Cascade.constArray n $ map constOf $ Butterworth.makeSines order psine <- LLVM.malloc LLVM.store sines psine s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ()) ps <- LLVM.malloc p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ())- let len = valueOf $ (TypeNum.fromIntegerT n :: Word32)+ let len = valueOf $ (TypeNum.integralFromProxy n :: Word32) _ <- U.arrayLoop len p s $ \ptri si -> do sinw <- LLVM.load si flip LLVM.store ptri =<<@@ -76,20 +74,17 @@ return (Cascade.ParameterValue pv) _parameterAlloca n kind ratio freq = do- let order = 2 * TypeNum.fromIntegerT n+ let order = 2 * TypeNum.integralFromProxy n partialRatio <- Value.unlift1 (Butterworth.partialRatio order) ratio let sines =- (flip const :: n -> LLVM.Value (LLVM.Array n a)- -> LLVM.Value (LLVM.Array n a)) n $- LLVM.value $- LLVM.constArray $+ Cascade.constArray n $ map constOf $ Butterworth.makeSines order psine <- LLVM.alloca LLVM.store sines psine s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ()) ps <- LLVM.alloca p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ())- let len = valueOf $ (TypeNum.fromIntegerT n :: Word32)+ let len = valueOf $ (TypeNum.integralFromProxy n :: Word32) _ <- U.arrayLoop len p s $ \ptri si -> do sinw <- LLVM.load si flip LLVM.store ptri =<<
src/Synthesizer/LLVM/Filter/Chebyshev.hs view
@@ -27,8 +27,9 @@ (Value, valueOf, IsSized, SizeOf, IsFloating, CodeGenFunction, ) import Data.Word (Word32, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num.Ops ((:*:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal.Number ((:*:), )+import Type.Base.Proxy (Proxy, ) import qualified Synthesizer.LLVM.Complex as ComplexL @@ -46,11 +47,11 @@ -} parameterA, parameterB :: (Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,- TypeNum.PositiveT n, TypeNum.NaturalT n,- TypeNum.PositiveT (n :*: SizeOf a),+ TypeNum.Positive n, TypeNum.Natural n,+ TypeNum.Positive (n :*: SizeOf a), IsSized (Cascade.ParameterStruct n a), SizeOf (Cascade.ParameterStruct n a) ~ paramSize,- (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.PositiveT paramSize) =>- n -> Passband -> Value a -> Value a ->+ (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.Positive paramSize) =>+ Proxy n -> Passband -> Value a -> Value a -> CodeGenFunction r (Cascade.ParameterValue n a) parameterA n kind ratio freq = do pv <- parameter Chebyshev.partialParameterA n kind ratio freq@@ -73,20 +74,17 @@ parameter :: (Trans.C a, SoV.RationalConstant a, IsFloating a, IsSized a, Value.T (Value a) ~ av,- TypeNum.PositiveT n, TypeNum.NaturalT n,- TypeNum.PositiveT (n :*: SizeOf a),+ TypeNum.Positive n, TypeNum.Natural n,+ TypeNum.Positive (n :*: SizeOf a), IsSized (Cascade.ParameterStruct n a), SizeOf (Cascade.ParameterStruct n a) ~ paramSize,- (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.PositiveT paramSize) =>+ (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.Positive paramSize) => (Passband -> Int -> av -> Complex.T av -> av -> Filt2Core.Parameter av) ->- n -> Passband -> Value a -> Value a ->+ Proxy n -> Passband -> Value a -> Value a -> CodeGenFunction r (Value (Cascade.ParameterStruct n a)) parameter partialParameter n kind ratio freq = do- let order = 2 * TypeNum.fromIntegerT n+ let order = 2 * TypeNum.integralFromProxy n let sines =- (flip const :: n -> LLVM.Value (LLVM.Array n a)- -> LLVM.Value (LLVM.Array n a)) n $- LLVM.value $- LLVM.constArray $+ Cascade.constArray n $ map ComplexL.constOf $ Chebyshev.makeCirclePoints order psine <- LLVM.malloc@@ -94,7 +92,7 @@ s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ()) ps <- LLVM.malloc p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ())- let len = valueOf $ (TypeNum.fromIntegerT n :: Word32)+ let len = valueOf $ (TypeNum.integralFromProxy n :: Word32) _ <- U.arrayLoop len p s $ \ptri si -> do c <- LLVM.load si flip LLVM.store ptri =<<
src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs view
@@ -21,7 +21,7 @@ import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Types.Data.Num (d0, d1, d2, )+import Type.Data.Num.Decimal (d0, d1, d2, ) import qualified Control.Applicative as App import qualified Data.Foldable as Fold
src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs view
@@ -28,8 +28,8 @@ CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num (D4, d0, d1, (:*:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D4, d0, d1, (:*:), ) import Control.Applicative (liftA2, ) @@ -61,7 +61,7 @@ parameterMemory :: (Memory.FirstClass a, Memory.Stored a ~ am, IsPrimitive a, IsPrimitive am,- TypeNum.PositiveT (TypeNum.D4 :*: LLVM.SizeOf am),+ TypeNum.Positive (TypeNum.D4 :*: LLVM.SizeOf am), IsSized am) => Memory.Record r (ParameterStruct am) (Parameter a) parameterMemory =@@ -83,7 +83,7 @@ (Memory.FirstClass a, Memory.Stored a ~ am, IsPrimitive a, IsPrimitive am, IsSized am,- TypeNum.PositiveT (TypeNum.D4 :*: LLVM.SizeOf am)) =>+ TypeNum.Positive (TypeNum.D4 :*: LLVM.SizeOf am)) => Memory.C (Parameter a) where type Struct (Parameter a) = ParameterStruct (Memory.Stored a) load = Memory.loadRecord parameterMemory
src/Synthesizer/LLVM/Filter/Moog.hs view
@@ -31,8 +31,9 @@ import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num (d0, d1, )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (d0, d1, )+import Type.Base.Proxy (Proxy(Proxy), ) import qualified Control.Arrow as Arrow import qualified Control.Applicative as App@@ -49,16 +50,16 @@ deriving (Functor, App.Applicative, Fold.Foldable, Trav.Traversable) -instance (Phi a, TypeNum.NaturalT n) =>+instance (Phi a, TypeNum.Natural n) => Phi (Parameter n a) where phis = Class.phisTraversable addPhis = Class.addPhisFoldable -instance (Undefined a, TypeNum.NaturalT n) =>+instance (Undefined a, TypeNum.Natural n) => Undefined (Parameter n a) where undefTuple = Class.undefTuplePointed -instance (Class.Zero a, TypeNum.NaturalT n) =>+instance (Class.Zero a, TypeNum.Natural n) => Class.Zero (Parameter n a) where zeroTuple = Class.zeroTuplePointed @@ -66,7 +67,7 @@ type ParameterStruct a = LLVM.Struct (a, (a, ())) parameterMemory ::- (Memory.C a, TypeNum.NaturalT n) =>+ (Memory.C a, TypeNum.Natural n) => Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter n a) parameterMemory = liftA2 (\f k -> Parameter (Moog.Parameter f k))@@ -74,7 +75,7 @@ (Memory.element (Moog.lowpassParam . getParam) d1) instance- (Memory.C a, TypeNum.NaturalT n) =>+ (Memory.C a, TypeNum.Natural n) => Memory.C (Parameter n a) where type Struct (Parameter n a) = ParameterStruct (Memory.Struct a) load = Memory.loadRecord parameterMemory@@ -83,29 +84,29 @@ compose = Memory.composeRecord parameterMemory -instance (Value.Flatten a, TypeNum.NaturalT n) => Value.Flatten (Parameter n a) where+instance (Value.Flatten a, TypeNum.Natural n) => Value.Flatten (Parameter n a) where type Registers (Parameter n a) = Parameter n (Value.Registers a) flattenCode = Value.flattenCodeTraversable unfoldCode = Value.unfoldCodeTraversable -instance (Vector.Simple v, TypeNum.NaturalT n) => Vector.Simple (Parameter n v) where+instance (Vector.Simple v, TypeNum.Natural n) => Vector.Simple (Parameter n v) where type Element (Parameter n v) = Parameter n (Vector.Element v) type Size (Parameter n v) = Vector.Size v shuffleMatch = Vector.shuffleMatchTraversable extract = Vector.extractTraversable -instance (Vector.C v, TypeNum.NaturalT n) => Vector.C (Parameter n v) where+instance (Vector.C v, TypeNum.Natural n) => Vector.C (Parameter n v) where insert = Vector.insertTraversable parameter ::- (A.Transcendental a, A.RationalConstant a, TypeNum.NaturalT n) =>- n -> a -> a ->+ (A.Transcendental a, A.RationalConstant a, TypeNum.Natural n) =>+ Proxy n -> a -> a -> CodeGenFunction r (Parameter n a) parameter order = Value.unlift2 $ \reson freq ->- Parameter $ Moog.parameter (TypeNum.fromIntegerT order) (Pole reson freq)+ Parameter $ Moog.parameter (TypeNum.integralFromProxy order) (Pole reson freq) merge ::@@ -130,16 +131,16 @@ causal :: (Causal.C process, Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,- TypeNum.NaturalT n) =>+ TypeNum.Natural n) => process (Parameter n a, v) v causal = causalSize (flip Causal.feedbackControlledZero (arr snd))- undefined+ Proxy causalP :: (Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,- TypeNum.NaturalT n) =>+ TypeNum.Natural n) => CausalP.T p (Parameter n a, v) v causalP = causal @@ -148,7 +149,7 @@ (Storable vh, Class.MakeValueTuple vh, Class.ValueTuple vh ~ v, Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,- TypeNum.NaturalT n) =>+ TypeNum.Natural n) => Param.T p vh -> CausalP.T p (Parameter n a, v) v causalInit = causalInitP causalInitP initial =@@ -158,19 +159,19 @@ (flip (CausalP.feedbackControlled initial) (arr $ selectOutput initial))- undefined+ Proxy causalSize :: (Causal.C process, Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,- TypeNum.NaturalT n) =>+ TypeNum.Natural n) => (process ((Parameter n a, v), v) v -> process (Parameter n a, v) v) ->- n ->+ Proxy n -> process (Parameter n a, v) v causalSize feedback n =- let order = TypeNum.fromIntegerT n+ let order = TypeNum.integralFromProxy n in Arrow.arr fst &&& feedback (Causal.zipWith merge >>>
src/Synthesizer/LLVM/Filter/NonRecursive.hs view
@@ -25,8 +25,8 @@ import qualified LLVM.Core as LLVM import LLVM.Core (Value, valueOf, CodeGenFunction, IsSized, SizeOf, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num.Ops ((:*:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal.Number ((:*:), ) import Foreign.ForeignPtr (touchForeignPtr, ) import Foreign.Storable (Storable, )@@ -61,7 +61,7 @@ convolvePacked :: (LLVM.IsPrimitive a, Memory.FirstClass a, Memory.Stored a ~ am, LLVM.IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT n, TypeNum.PositiveT (n :*: amsize),+ TypeNum.Positive n, TypeNum.Positive (n :*: amsize), Class.MakeValueTuple a, Class.ValueTuple a ~ al, Memory.Struct al ~ am, Storable a, Memory.C al, LLVM.IsArithmetic a) =>@@ -120,7 +120,7 @@ scalarProductPacked :: (LLVM.IsPrimitive a, Memory.FirstClass a, Memory.Stored a ~ am, LLVM.IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT n, TypeNum.PositiveT (n :*: amsize),+ TypeNum.Positive n, TypeNum.Positive (n :*: amsize), LLVM.IsArithmetic a) => Value Word32 -> RingBuffer.T (Serial.Value n a) -> Value (Ptr am) ->@@ -153,7 +153,7 @@ readSerialStart :: (LLVM.IsPrimitive a, Memory.FirstClass a, Memory.Stored a ~ am, LLVM.IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT n, TypeNum.PositiveT (n :*: amsize)) =>+ TypeNum.Positive n, TypeNum.Positive (n :*: amsize)) => RingBuffer.T (Serial.Value n a) -> CodeGenFunction r (Serial.Value n a, Iterator n a) readSerialStart rb = do@@ -163,7 +163,7 @@ readSerialNext :: (LLVM.IsPrimitive a, Memory.FirstClass a, Memory.Stored a ~ am, LLVM.IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT n, TypeNum.PositiveT (n :*: amsize)) =>+ TypeNum.Positive n, TypeNum.Positive (n :*: amsize)) => RingBuffer.T (Serial.Value n a) -> Iterator n a -> CodeGenFunction r (Serial.Value n a, Iterator n a)
src/Synthesizer/LLVM/Filter/SecondOrder.hs view
@@ -32,8 +32,8 @@ import LLVM.Core (CodeGenFunction, valueOf, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num (d0, d1, d2, d3, d4, )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (d0, d1, d2, d3, d4, ) import Control.Arrow (arr, (<<<), (&&&), ) import Control.Monad (liftM2, foldM, )
src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs view
@@ -8,7 +8,7 @@ causalP, causalPackedP, ParameterValue(..), ParameterStruct,- fixSize,+ fixSize, constArray, ) where import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2@@ -31,11 +31,11 @@ import LLVM.Util.Loop (Phi, phis, addPhis, ) import LLVM.Core (Value, IsArithmetic, IsSized, CodeGenFunction, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num.Ops ((:*:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal.Number ((:*:), )+import Type.Base.Proxy (Proxy, ) import Data.Word (Word32, )-import Data.Tuple.HT (mapSnd, ) import qualified Control.Arrow as Arrow import Control.Arrow ((>>>), (<<<), (^<<), (<<^), (&&&), arr, )@@ -63,7 +63,7 @@ Functor, App.Applicative, Fold.Foldable, Trav.Traversable) -} -instance (TypeNum.NaturalT n, IsSized a) =>+instance (TypeNum.Natural n, IsSized a) => Phi (ParameterValue n a) where phis bb (ParameterValue r) = fmap ParameterValue $ phis bb r@@ -72,17 +72,17 @@ (ParameterValue r') = addPhis bb r r' -instance (TypeNum.NaturalT n, IsSized a) =>+instance (TypeNum.Natural n, IsSized a) => Class.Undefined (ParameterValue n a) where undefTuple = ParameterValue Class.undefTuple -instance (TypeNum.NaturalT n, IsSized a) =>+instance (TypeNum.Natural n, IsSized a) => Class.Zero (ParameterValue n a) where zeroTuple = ParameterValue Class.zeroTuple -instance (TypeNum.IntegerT n, TypeNum.NaturalT n,+instance (TypeNum.Natural n, Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,- TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ TypeNum.Positive (n :*: LLVM.UnknownSize)) => Memory.C (ParameterValue n a) where type Struct (ParameterValue n a) = ParameterStruct n (Memory.Stored a) load = Memory.loadNewtype ParameterValue@@ -96,22 +96,30 @@ withSize ::- (n -> process (ParameterValue n a, x) y) ->+ (TypeNum.Natural n) =>+ (TypeNum.Singleton n -> process (ParameterValue n a, x) y) -> process (ParameterValue n a, x) y-withSize f = f undefined+withSize f = f TypeNum.singleton fixSize ::- n ->+ Proxy n -> process (ParameterValue n a, x) y -> process (ParameterValue n a, x) y fixSize _n = id +constArray ::+ (TypeNum.Natural n, IsSized a) =>+ Proxy n -> [LLVM.ConstValue a] ->+ LLVM.Value (LLVM.Array n a)+constArray _n = LLVM.value . LLVM.constArray++ causalP :: (LLVM.Value a ~ A.Scalar v, A.PseudoModule v, Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, Memory.C v,- IsArithmetic a, SoV.IntegerConstant a, TypeNum.NaturalT n,- TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ IsArithmetic a, SoV.IntegerConstant a, TypeNum.Natural n,+ TypeNum.Positive (n :*: LLVM.UnknownSize)) => CausalP.T p (ParameterValue n a, v) v causalP = causal @@ -123,8 +131,8 @@ Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, LLVM.IsPrimitive a, LLVM.IsPrimitive am,- TypeNum.PositiveT (n :*: LLVM.UnknownSize),- TypeNum.NaturalT n) =>+ TypeNum.Positive (n :*: LLVM.UnknownSize),+ TypeNum.Natural n) => CausalP.T p (ParameterValue n a, v) v causalPackedP = causalPacked @@ -134,8 +142,8 @@ LLVM.Value a ~ A.Scalar v, A.PseudoModule v, Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, Memory.C v,- IsArithmetic a, SoV.IntegerConstant a, TypeNum.NaturalT n,- TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ IsArithmetic a, SoV.IntegerConstant a, TypeNum.Natural n,+ TypeNum.Positive (n :*: LLVM.UnknownSize)) => process (ParameterValue n a, v) v causal = causalGen Filt2.causal @@ -148,14 +156,14 @@ Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, LLVM.IsPrimitive a, LLVM.IsPrimitive am,- TypeNum.PositiveT (n :*: LLVM.UnknownSize),- TypeNum.NaturalT n) =>+ TypeNum.Positive (n :*: LLVM.UnknownSize),+ TypeNum.Natural n) => process (ParameterValue n a, v) v causalPacked = causalGen Filt2.causalPacked causalGen :: (Causal.C process, IsSized a, Phi v, Undefined v,- TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) => process (Filt2Core.Parameter (Value a), v) v -> process (ParameterValue n a, v) v causalGen stage =@@ -163,14 +171,14 @@ snd ^<< Causal.replicateControlled- (TypeNum.fromIntegerT n)+ (TypeNum.integralFromSingleton n) (paramStage stage) <<^ (\(p,v) -> (p, (A.zero, v))) paramStage :: (Causal.C process, IsSized a,- TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) => process (Filt2Core.Parameter (Value a), v) v -> process (ParameterValue n a, (Value Word32, v)) (Value Word32, v) paramStage stage =@@ -186,22 +194,20 @@ _paramStage :: (IsSized a,- TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) => CausalP.T p (Filt2Core.Parameter (Value a), v) v -> CausalP.T p (ParameterValue n a, (Value Word32, v)) (Value Word32, v) _paramStage stage =- (Func.withArgs $ \(p,(i,v)) ->+ Func.withGuidedArgs (Func.atom, (Func.atom, Func.atom)) $ \(p,(i,v)) -> liftA2 (,) (i+1) (stage $& (Causal.zipWith getStageParameterAlloca $& p &|& i) &|&- v))- <<^- mapSnd (mapSnd Func.AnyArg)+ v) _causalGenP :: (Causal.C process, IsSized a,- TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) => process (Filt2Core.Parameter (Value a), v) v -> process (ParameterValue n a, v) v _causalGenP stage =@@ -211,12 +217,12 @@ (\k -> stage <<< Arrow.first (Causal.map (flip getStageParameter k)))- (take (TypeNum.fromIntegerT n) [0..])+ (take (TypeNum.integralFromSingleton n) [0..]) getStageParameter :: (IsSized a,- TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) => ParameterValue n a -> Word32 -> CodeGenFunction r (Filt2Core.Parameter (Value a))@@ -230,7 +236,7 @@ _getStageParameterMalloc, getStageParameterAlloca :: (IsSized a,- TypeNum.NaturalT n, TypeNum.PositiveT (n :*: LLVM.UnknownSize)) =>+ TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) => ParameterValue n a -> Value Word32 -> CodeGenFunction r (Filt2Core.Parameter (Value a))
src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs view
@@ -26,8 +26,8 @@ CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num (D4, d0, d1, (:*:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D4, d0, d1, (:*:), ) import Control.Applicative (liftA2, ) @@ -68,7 +68,7 @@ parameterMemory :: (Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, IsPrimitive a, IsPrimitive am,- TypeNum.PositiveT (D4 :*: LLVM.SizeOf am)) =>+ TypeNum.Positive (D4 :*: LLVM.SizeOf am)) => Memory.Record r (ParameterStruct am) (Parameter a) parameterMemory = liftA2 Parameter@@ -78,7 +78,7 @@ instance (Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, IsPrimitive a, IsPrimitive am,- TypeNum.PositiveT (D4 :*: LLVM.SizeOf am)) =>+ TypeNum.Positive (D4 :*: LLVM.SizeOf am)) => Memory.C (Parameter a) where type Struct (Parameter a) = ParameterStruct (Memory.Stored a) load = Memory.loadRecord parameterMemory
src/Synthesizer/LLVM/Filter/Universal.hs view
@@ -27,7 +27,7 @@ import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Types.Data.Num (d0, d1, d2, d3, d4, d5, )+import Type.Data.Num.Decimal (d0, d1, d2, d3, d4, d5, ) import Synthesizer.ApplicativeUtility (liftA6, )
src/Synthesizer/LLVM/Frame.hs view
@@ -13,8 +13,8 @@ (CodeGenFunction, Value, Vector, IsPrimitive, IsArithmetic, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num (D2, D4, )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D2, D4, ) import Foreign.Storable.Tuple () @@ -91,13 +91,13 @@ stereoFromVector =<< A.add xv yv mixVector ::- (Vector.Arithmetic a, TypeNum.PositiveT n) =>+ (Vector.Arithmetic a, TypeNum.Positive n) => Value (Vector n a) -> CodeGenFunction r (Value a) mixVector = Vector.sum mixVectorToStereo ::- (Vector.Arithmetic a, TypeNum.PositiveT n) =>+ (Vector.Arithmetic a, TypeNum.Positive n) => Value (Vector n a) -> CodeGenFunction r (Stereo.T (Value a)) mixVectorToStereo =@@ -109,7 +109,7 @@ and components with odd index to the right channel. -} mixInterleavedVectorToStereo ::- (Vector.Arithmetic a, TypeNum.PositiveT n) =>+ (Vector.Arithmetic a, TypeNum.Positive n) => Value (Vector n a) -> CodeGenFunction r (Stereo.T (Value a)) mixInterleavedVectorToStereo =
src/Synthesizer/LLVM/Frame/SerialVector.hs view
@@ -31,25 +31,25 @@ extractAll, assemble, modify, upsample, subsample,- cumulate, iterate, reverse,+ cumulate, iterate, iteratePlain, reverse, shiftUp, shiftUpMultiZero, shiftDownMultiZero,- replicate, replicateOf, fromList,- mapV, zipV,+ replicate, replicateOf, fromList, fromFixedList,+ mapPlain, mapV, zipV, ) where import qualified Synthesizer.LLVM.Frame.Stereo as Stereo-import qualified Synthesizer.LLVM.CausalParameterized.Functional as F import qualified LLVM.Extra.Vector as Vector import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Class (MakeValueTuple, valueTupleOf, )+ import qualified LLVM.Util.Loop as Loop import qualified LLVM.Core as LLVM-import LLVM.Extra.Class (MakeValueTuple, valueTupleOf, ) import LLVM.Util.Loop (Phi, ) -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum import qualified Foreign.Storable as St import Data.Word (Word32, )@@ -60,6 +60,8 @@ import qualified Control.Applicative as App import qualified Data.Traversable as Trav +import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty import qualified Data.List.HT as ListHT import qualified Data.List as List import Data.Tuple.HT (mapSnd, fst3, snd3, thd3, )@@ -139,11 +141,6 @@ scale a (Cons v) = fmap Cons $ A.scale a v -type instance F.Arguments f (T v) = f (T v)-instance F.MakeArguments (T v) where- makeArgs = id-- type Plain n a = T (LLVM.Vector n a) type Value n a = T (LLVM.Value (LLVM.Vector n a)) @@ -155,16 +152,21 @@ value = Cons -replicate :: (TypeNum.PositiveT n) => a -> Plain n a-replicate x = Cons $ LLVM.vector [x]+replicate :: (TypeNum.Positive n) => a -> Plain n a+replicate x = Cons $ App.pure x -replicateOf :: (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsConst a) => a -> Value n a-replicateOf x = Cons $ LLVM.valueOf $ LLVM.vector [x]+replicateOf :: (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsConst a) => a -> Value n a+replicateOf x = Cons $ LLVM.valueOf $ App.pure x -fromList :: (TypeNum.PositiveT n) => [a] -> Plain n a-fromList = Cons . LLVM.vector+fromList :: (TypeNum.Positive n) => NonEmpty.T [] a -> Plain n a+fromList = Cons . LLVM.cyclicVector -constant :: (TypeNum.PositiveT n) => a -> T (Vector.Constant n a)+fromFixedList ::+ (TypeNum.Positive n) =>+ LLVM.FixedList (TypeNum.ToUnary n) a -> Plain n a+fromFixedList = Cons . LLVM.vector++constant :: (TypeNum.Positive n) => a -> T (Vector.Constant n a) constant = Cons . Vector.constant @@ -218,7 +220,7 @@ class- (TypeNum.PositiveT (Size v), Sized v,+ (TypeNum.Positive (Size v), Sized v, Phi (ReadIt v), Class.Undefined (ReadIt v), Phi v, Class.Undefined v) => Read v where@@ -456,13 +458,21 @@ cumulate ::- (Vector.Arithmetic a, TypeNum.PositiveT n) =>+ (Vector.Arithmetic a, TypeNum.Positive n) => LLVM.Value a -> Value n a -> LLVM.CodeGenFunction r (LLVM.Value a, Value n a) cumulate x (Cons v) = fmap (mapSnd Cons) $ Vector.cumulate x v +mapPlain ::+ (TypeNum.Positive n) => (a -> b) -> Plain n a -> Plain n b+mapPlain f (Cons v) = Cons $ fmap f v++iteratePlain ::+ (TypeNum.Positive n) => (a -> a) -> a -> Plain n a+iteratePlain f x = fromList $ NonEmptyC.iterate f x+ iterate :: (C v) => (Element v -> LLVM.CodeGenFunction r (Element v)) ->@@ -593,28 +603,28 @@ withSize :: Sized v => (Int -> m v) -> m v withSize =- let sz :: (Sized v) => Size v -> (Int -> m v) -> m v- sz n f = f (TypeNum.fromIntegerT n)- in sz undefined+ let sz :: (Sized v) => TypeNum.Singleton (Size v) -> (Int -> m v) -> m v+ sz n f = f (TypeNum.integralFromSingleton n)+ in sz TypeNum.singleton size :: Sized v => v -> Int size =- let sz :: (Sized v) => Size v -> v -> Int- sz n _ = TypeNum.fromIntegerT n- in sz undefined+ let sz :: (Sized v) => TypeNum.Singleton (Size v) -> v -> Int+ sz n _ = TypeNum.integralFromSingleton n+ in sz TypeNum.singleton sizeOfIterator :: Sized v => Iterator mode it v -> Int sizeOfIterator =- let sz :: Sized v => v -> Iterator mode it v -> Int- sz v _ = size v- in sz undefined+ let sz :: Sized v => TypeNum.Singleton (Size v) -> Iterator mode it v -> Int+ sz n _ = TypeNum.integralFromSingleton n+ in sz TypeNum.singleton {- | The type parameter @value@ shall be a virtual LLVM register or a wrapper around one or more virtual LLVM registers. -}-class (TypeNum.PositiveT (Size valueTuple)) => Sized valueTuple where+class (TypeNum.Positive (Size valueTuple)) => Sized valueTuple where type Size valueTuple :: * serialSize :: valueTuple -> Size valueTuple serialSize _ = error "serial size is a type number and has no value"
src/Synthesizer/LLVM/Frame/Stereo.hs view
@@ -31,7 +31,7 @@ MakeValueTuple, ValueTuple, valueTupleOf, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import Types.Data.Num (d0, d1, )+import Type.Data.Num.Decimal (d0, d1, ) import Control.Monad (liftM2, ) import Control.Applicative (liftA2, )
src/Synthesizer/LLVM/Frame/StereoInterleaved.hs view
@@ -51,7 +51,7 @@ (Vector, IsSized, SizeOf, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum import Foreign.Ptr (castPtr, ) import qualified Foreign.Storable as St@@ -76,36 +76,38 @@ makeArgs = id -withSize :: (TypeNum.IntegerT n) => (Int -> m (Value n a)) -> m (Value n a)+withSize :: (TypeNum.Natural n) => (Int -> m (Value n a)) -> m (Value n a) withSize =- let sz :: (TypeNum.IntegerT n) => n -> (Int -> m (Value n a)) -> m (Value n a)- sz n f = f (TypeNum.fromIntegerT n)- in sz undefined+ let sz ::+ (TypeNum.Natural n) =>+ TypeNum.Singleton n -> (Int -> m (Value n a)) -> m (Value n a)+ sz n f = f (TypeNum.integralFromSingleton n)+ in sz TypeNum.singleton interleave ::- (LLVM.IsPrimitive a, TypeNum.PositiveT n) =>+ (LLVM.IsPrimitive a, TypeNum.Positive n) => Stereo.T (Serial.Value n a) -> LLVM.CodeGenFunction r (Value n a) interleave x = assemble =<< Serial.extractAll x deinterleave ::- (LLVM.IsPrimitive a, TypeNum.PositiveT n) =>+ (LLVM.IsPrimitive a, TypeNum.Positive n) => Value n a -> LLVM.CodeGenFunction r (Stereo.T (Serial.Value n a)) deinterleave v = Serial.assemble =<< extractAll v fromMono ::- (LLVM.IsPrimitive a, TypeNum.PositiveT n) =>+ (LLVM.IsPrimitive a, TypeNum.Positive n) => Serial.Value n a -> LLVM.CodeGenFunction r (Value n a) fromMono x = assemble . map pure =<< Serial.extractAll x assemble ::- (LLVM.IsPrimitive a, TypeNum.IntegerT n, TypeNum.PositiveT n) =>+ (LLVM.IsPrimitive a, TypeNum.Positive n) => [Stereo.T (LLVM.Value a)] -> LLVM.CodeGenFunction r (Value n a) assemble x = withSize $ \n ->@@ -115,7 +117,7 @@ concatMap Fold.toList $ x extractAll ::- (LLVM.IsPrimitive a, TypeNum.IntegerT n, TypeNum.PositiveT n) =>+ (LLVM.IsPrimitive a, TypeNum.Positive n) => Value n a -> LLVM.CodeGenFunction r [Stereo.T (LLVM.Value a)] extractAll (Value v0 v1) = fmap@@ -129,7 +131,7 @@ instance- (TypeNum.PositiveT n, LLVM.IsPrimitive a, St.Storable a) =>+ (TypeNum.Positive n, LLVM.IsPrimitive a, St.Storable a) => St.Storable (T n a) where sizeOf ~(Cons v0 v1) = St.sizeOf v0 + St.sizeOf v1 alignment ~(Cons v _) = St.alignment v@@ -143,17 +145,17 @@ in St.pokeElemOff p 0 v0 >> St.pokeElemOff p 1 v1 -instance (TypeNum.PositiveT n, LLVM.IsPrimitive a) => Class.Zero (Value n a) where+instance (TypeNum.Positive n, LLVM.IsPrimitive a) => Class.Zero (Value n a) where zeroTuple = Value Class.zeroTuple Class.zeroTuple -instance (TypeNum.PositiveT n, LLVM.IsPrimitive a) => Undefined (Value n a) where+instance (TypeNum.Positive n, LLVM.IsPrimitive a) => Undefined (Value n a) where undefTuple = Value (LLVM.value LLVM.undef) (LLVM.value LLVM.undef) {- Can only be implemented by ifThenElse since the atomic 'select' command wants a bool vector. -instance (TypeNum.PositiveT n, LLVM.IsPrimitive a, Phi a) => C.Select (Value n a) where+instance (TypeNum.Positive n, LLVM.IsPrimitive a, Phi a) => C.Select (Value n a) where select b (Value x0 x1) (Value y0 y1) = liftM2 Value (C.select b x0 y0)@@ -162,7 +164,7 @@ instance LLVM.CmpRet a, LLVM.CmpResult a ~ b => LLVM.CmpRet (Stereo.T a) (Stereo.T b) where -} -instance (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsConst a) =>+instance (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsConst a) => MakeValueTuple (T n a) where type ValueTuple (T n a) = Value n a valueTupleOf (Cons v0 v1) =@@ -170,19 +172,19 @@ (LLVM.valueOf v0) (LLVM.valueOf v1) -instance (TypeNum.PositiveT n, LLVM.IsPrimitive a) => Phi (Value n a) where+instance (TypeNum.Positive n, LLVM.IsPrimitive a) => Phi (Value n a) where phis bb = mapV (phis bb) addPhis bb = zipV (\_ _ -> ()) (addPhis bb) -instance (TypeNum.PositiveT n) => Serial.Sized (Value n a) where+instance (TypeNum.Positive n) => Serial.Sized (Value n a) where type Size (Value n a) = n {- | The implementation of 'extract' may need to perform arithmetics at run-time and is thus a bit inefficient. -}-instance (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsFirstClass a) => Serial.Read (Value n a) where+instance (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsFirstClass a) => Serial.Read (Value n a) where type Element (Value n a) = Stereo.T (LLVM.Value a) type ReadIt (Value n a) = Value n a @@ -213,7 +215,7 @@ The implementation of 'insert' may need to perform arithmetics at run-time and is thus a bit inefficient. -}-instance (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsFirstClass a) => Serial.C (Value n a) where+instance (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsFirstClass a) => Serial.C (Value n a) where type WriteIt (Value n a) = Value n a insert k x v =@@ -243,9 +245,9 @@ type Struct n a = LLVM.Struct (Vector n a, (Vector n a, ())) memory ::- (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsPrimitive am,+ (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsPrimitive am, Memory.FirstClass a, Memory.Stored a ~ am,- IsSized am, TypeNum.PositiveT (n TypeNum.:*: SizeOf am)) =>+ IsSized am, TypeNum.Positive (n TypeNum.:*: SizeOf am)) => Memory.Record r (Struct n am) (Value n a) memory = liftA2 Value@@ -253,12 +255,12 @@ (Memory.element (\(Value _ v) -> v) TypeNum.d1) instance- (TypeNum.PositiveT n,+ (TypeNum.Positive n, Memory.FirstClass a, Memory.Stored a ~ am, LLVM.IsPrimitive a, IsSized a,- TypeNum.PositiveT (n TypeNum.:*: SizeOf a),+ TypeNum.Positive (n TypeNum.:*: SizeOf a), LLVM.IsPrimitive am, IsSized am,- TypeNum.PositiveT (n TypeNum.:*: SizeOf am)) =>+ TypeNum.Positive (n TypeNum.:*: SizeOf am)) => Memory.C (Value n a) where type Struct (Value n a) = Struct n (Memory.Stored a) load = Memory.loadRecord memory@@ -270,7 +272,7 @@ This instance allows to run @arrange@ on interleaved stereo vectors. -} instance- (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>+ (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) => A.Additive (Value n a) where zero = Value A.zero A.zero add = zipV Value A.add@@ -278,24 +280,24 @@ neg = mapV A.neg -zero :: (TypeNum.PositiveT n, Additive.C a) => (T n a)-zero = Cons (LLVM.vector [Additive.zero]) (LLVM.vector [Additive.zero])+zero :: (TypeNum.Positive n, Additive.C a) => (T n a)+zero = Cons (pure Additive.zero) (pure Additive.zero) scale ::- (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>+ (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) => LLVM.Value a -> Value n a -> LLVM.CodeGenFunction r (Value n a) scale a v = do av <- SoV.replicate a mapV (A.mul av) v amplify ::- (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a, LLVM.IsConst a) =>+ (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a, LLVM.IsConst a) => a -> Value n a -> LLVM.CodeGenFunction r (Value n a) amplify a = scale (LLVM.valueOf a) envelope ::- (TypeNum.PositiveT n, LLVM.IsPrimitive a, LLVM.IsArithmetic a, LLVM.IsConst a) =>+ (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a, LLVM.IsConst a) => Serial.Value n a -> Value n a -> LLVM.CodeGenFunction r (Value n a) envelope e a = zipV Value (flip A.mul) a =<< fromMono e
src/Synthesizer/LLVM/Generator/Exponential2.hs view
@@ -37,8 +37,8 @@ CodeGenFunction, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num.Ops ((:*:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal.Number ((:*:), ) import Foreign.Storable (Storable, ) import qualified Foreign.Storable@@ -260,10 +260,11 @@ withSize ::- (Serial.C v, Serial.Size v ~ n, TypeNum.PositiveT n) =>- (n -> m (param v)) ->+ (TypeNum.Natural n) =>+ (Serial.C v, Serial.Size v ~ n, TypeNum.Positive n) =>+ (TypeNum.Singleton n -> m (param v)) -> m (param v)-withSize f = f undefined+withSize f = f TypeNum.singleton parameterPacked :: (Serial.C v, Serial.Element v ~ a,@@ -274,7 +275,7 @@ feedback <- Serial.upsample =<< A.pow (A.fromRational' 0.5) =<<- A.fdiv (A.fromInteger' $ TypeNum.fromIntegerT n) halfLife+ A.fdiv (A.fromInteger' $ TypeNum.integralFromSingleton n) halfLife k <- A.pow (A.fromRational' 0.5) =<< A.fdiv (A.fromInteger' 1) halfLife@@ -286,29 +287,30 @@ -} withSizePlain ::- (n -> param (Serial.Plain n a)) ->+ (TypeNum.Natural n) =>+ (TypeNum.Singleton n -> param (Serial.Plain n a)) -> param (Serial.Plain n a)-withSizePlain f = f undefined+withSizePlain f = f TypeNum.singleton parameterPackedPlain :: (Trans.C a,- TypeNum.PositiveT n) =>+ TypeNum.Positive n) => a -> ParameterPacked (Serial.Plain n a) parameterPackedPlain halfLife = withSizePlain $ \n -> ParameterPacked- (Serial.replicate (0.5 ** (fromInteger (TypeNum.fromIntegerT n) / halfLife)))- (Serial.fromList $ iterate (0.5 ** recip halfLife *) one)+ (Serial.replicate (0.5 ** (fromInteger (TypeNum.integralFromSingleton n) / halfLife)))+ (Serial.iteratePlain (0.5 ** recip halfLife *) one) causalPackedP :: (IsArithmetic a, SoV.IntegerConstant a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a),- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, IsPrimitive a, IsPrimitive am,- TypeNum.PositiveT (n :*: SizeOf a),- TypeNum.PositiveT (n :*: SizeOf am),- TypeNum.PositiveT n) =>+ TypeNum.Positive (n :*: SizeOf a),+ TypeNum.Positive (n :*: SizeOf am),+ TypeNum.Positive n) => Param.T p a -> CausalP.T p (ParameterPacked (Serial.Value n a)) (Serial.Value n a) causalPackedP initial =
src/Synthesizer/LLVM/Interpolation.hs view
@@ -36,7 +36,7 @@ import Foreign.Ptr (Ptr, ) import Data.Word (Word32, ) -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum import qualified Control.Monad.Trans.State as MS import Control.Applicative (Applicative, liftA2, pure, (<*>), )
src/Synthesizer/LLVM/MIDI.hs view
@@ -32,8 +32,8 @@ import qualified LLVM.Core as LLVM import LLVM.Core (IsSized, SizeOf, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num.Ops ((:*:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal.Number ((:*:), ) import Foreign.Storable (Storable, ) @@ -42,7 +42,6 @@ import Control.Arrow (second, (<<<), (<<^), ) import Control.Monad ({- liftM, -} liftM2, )-import Data.Tuple.HT (mapPair, ) -- import NumericPrelude.Base import NumericPrelude.Numeric@@ -159,9 +158,9 @@ LLVM.IsPrimitive am, Storable a, Class.MakeValueTuple a, Class.ValueTuple a ~ (LLVM.Value a), Vector.Real a, SoV.IntegerConstant a,- TypeNum.PositiveT n,- TypeNum.PositiveT (n :*: SizeOf a),- TypeNum.PositiveT (n :*: SizeOf am)) =>+ TypeNum.Positive n,+ TypeNum.Positive (n :*: SizeOf a),+ TypeNum.Positive (n :*: SizeOf am)) => Param.T p a -> CausalP.T p (BM.T (LLVM.Value a)) (Serial.Value n a) frequencyFromBendModulationPacked speed =@@ -178,10 +177,8 @@ Param.T p y -> CausalP.T p (yl,yl) yl frequencyFromPair osci speed =- (Func.withArgs $ \(b, m) ->- b * (1 + m * Func.fromSignal (osci Wave.approxSine2 zero speed)))- <<^- mapPair (Func.AnyArg, Func.AnyArg)+ Func.withGuidedArgs (Func.atom, Func.atom) $ \(b, m) ->+ b * (1 + m * Func.fromSignal (osci Wave.approxSine2 zero speed)) _frequencyFromPair osci speed = CausalP.envelope
src/Synthesizer/LLVM/MIDI/BendModulation.hs view
@@ -22,7 +22,7 @@ import qualified LLVM.Core as LLVM import Control.Applicative (liftA2, )-import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum instance (Class.Zero a) => Class.Zero (BM.T a) where
src/Synthesizer/LLVM/Parameterized/Signal.hs view
@@ -5,14 +5,20 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Parameterized.Signal (- T(Cons), simple, map, mapSimple, zipWith, zipWithSimple, iterate,+ T(Cons), simple, constant, iterate,+ map, mapSimple, zip, zipWith, zipWithSimple,+ Sig.mix, Sig.envelope, Sig.envelopeStereo, module Synthesizer.LLVM.Parameterized.Signal ) where import Synthesizer.LLVM.Parameterized.SignalPrivate+import qualified Synthesizer.LLVM.Simple.Signal as Sig import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP-import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Interpolation as Interpolation import qualified Synthesizer.LLVM.ConstantPiece as Const+import qualified Synthesizer.LLVM.Parameter as Param+import Synthesizer.Causal.Class (($*), ($<), ) import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame@@ -39,7 +45,7 @@ import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.ForeignPtr as ForeignPtr import qualified LLVM.Extra.Memory as Memory-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, )+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) import LLVM.Extra.Control (whileLoop, ifThen, ) @@ -51,12 +57,12 @@ CodeGenModule, Linkage(ExternalLinkage), Function, createNamedFunction, ) -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum import Control.Monad.HT ((<=<), ) import Control.Monad (liftM2, liftM3, when, ) import Control.Arrow ((^<<), )-import Control.Applicative (liftA2, )+import Control.Applicative (liftA2, pure, ) import Control.Functor.HT (void, ) import qualified Algebra.Transcendental as Trans@@ -80,14 +86,15 @@ import qualified Synthesizer.LLVM.Debug.Counter as Counter import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, cycle, )+import NumericPrelude.Base hiding (and, tail, iterate, map, zip, zipWith, cycle, ) -- for debugMain import qualified Control.Monad.Trans.Reader as R -zip :: T p a -> T p b -> T p (a,b)-zip = liftA2 (,)+reparameterize :: Param.T q p -> T p a -> T q a+reparameterize p (Cons start stop next create delete) =+ Cons start stop next (create . Param.get p) delete -- * timeline edit@@ -218,38 +225,13 @@ (Memory.C a, IsFloating b, SoV.IntegerConstant b, LLVM.CmpRet b, LLVM.CmpResult b ~ Bool, Storable b, MakeValueTuple b, ValueTuple b ~ (Value b),- Memory.FirstClass b, IsSized b, IsSized (Memory.Stored b)) =>+ Memory.FirstClass b, IsSized (Memory.Stored b)) => Param.T p b -> T p a -> T p a-interpolateConstant k- (Cons next start stop createIOContext deleteIOContext) =- Param.with k $ \getK valueK -> Cons- (quantizeNext next valueK)- (quantizeStart start)- (quantizeStop stop)- (quantizeCreate createIOContext getK)- (quantizeDelete deleteIOContext)----mix ::- (A.Additive a) =>- T p a -> T p a -> T p a-mix =- zipWithSimple Frame.mix+interpolateConstant k sig =+ CausalP.toSignal+ (Causal.quantizeLift (CausalP.fromSignal sig) $< constant k) -envelope ::- (A.PseudoRing a) =>- T p a -> T p a -> T p a-envelope =- zipWithSimple Frame.amplifyMono--envelopeStereo ::- (A.PseudoRing a) =>- T p a -> T p (Stereo.T a) -> T p (Stereo.T a)-envelopeStereo =- zipWithSimple Frame.amplifyStereo- amplify :: (A.PseudoRing al, Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) =>@@ -265,19 +247,45 @@ map Frame.amplifyStereo --- * signal generators+mapAccum ::+ (Storable pnh, MakeValueTuple pnh, ValueTuple pnh ~ pnl, Memory.C pnl,+ Storable psh, MakeValueTuple psh, ValueTuple psh ~ psl, Memory.C psl,+ Memory.C s) =>+ (forall r. pnl -> a -> s -> CodeGenFunction r (b,s)) ->+ (forall r. psl -> CodeGenFunction r s) ->+ Param.T p pnh ->+ Param.T p psh ->+ T p a -> T p b+mapAccum next start n s xs =+ CausalP.mapAccum next start n s $* xs -constant ::- (Storable a, MakeValueTuple a, ValueTuple a ~ al,- Memory.C al) =>- Param.T p a -> T p al-constant x =- simple- (\pl () -> return (pl, ()))- (return . flip (,) ())- x+adjacentNodes02 ::+ (Memory.C a, Undefined a) =>+ T p a -> T p (Interpolation.Nodes02 a)+adjacentNodes02 =+ tail+ .+ Sig.mapAccum+ (\new old -> return (Interpolation.Nodes02 old new, new))+ (return undefTuple) +adjacentNodes13 ::+ (MakeValueTuple ah, Storable ah, ValueTuple ah ~ a,+ Memory.C a, Undefined a) =>+ Param.T p ah -> T p a -> T p (Interpolation.Nodes13 a)+adjacentNodes13 yp0 =+ tail .+ tail .+ mapAccum+ (\() new (x0, x1, x2) ->+ return (Interpolation.Nodes13 x0 x1 x2 new, (x1, x2, new)))+ (\y0 -> return (undefTuple, undefTuple, Param.value yp0 y0))+ (pure ()) yp0 ++-- * signal generators++ exponentialCore :: (Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al, A.PseudoRing al) =>@@ -287,7 +295,7 @@ exponential2 :: (Trans.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a),- Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a),+ Memory.FirstClass a, IsSized (Memory.Stored a), IsArithmetic a, IsConst a) => Param.T p a -> Param.T p a -> T p (Value a) exponential2 halfLife =@@ -312,7 +320,7 @@ -} exponentialBounded2 :: (Trans.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a),- Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a),+ Memory.FirstClass a, IsSized (Memory.Stored a), SoV.Real a, IsConst a) => Param.T p a -> Param.T p a -> Param.T p a -> T p (Value a)@@ -457,7 +465,7 @@ (Algebraic.C a, IsFloating a, IsConst a, LLVM.NumberOfElements a ~ TypeNum.D1, Memory.C (Value a),- IsSized a, MakeValueTuple a, ValueTuple a ~ (Value a), Storable a) =>+ MakeValueTuple a, ValueTuple a ~ (Value a), Storable a) => Param.T p Word32 -> Param.T p a -> T p (Value a)
src/Synthesizer/LLVM/Parameterized/SignalPacked.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE FlexibleContexts #-} {- | Signal generators that generate the signal in chunks that can be processed natively by the processor.@@ -21,10 +19,24 @@ But since we use the term Vector already in the mathematical sense, I like to use the term "packed" that is used in Intel mnemonics like mulps. -}-module Synthesizer.LLVM.Parameterized.SignalPacked where+module Synthesizer.LLVM.Parameterized.SignalPacked (+ SigS.pack, SigS.packRotate,+ SigS.packSmall,+ SigS.unpack, SigS.unpackRotate,+ constant,+ exponential2,+ exponentialBounded2,+ osciCore,+ osci,+ osciSimple,+ parabolaFadeInInf, parabolaFadeOutInf,+ rampInf, rampSlope,+ noise,+ noiseCore, noiseCoreAlt,+ ) where -import Synthesizer.LLVM.Parameterized.Signal (T(Cons), )-import Synthesizer.LLVM.Parameterized.SignalPrivate (withStart, )+import Synthesizer.LLVM.Parameterized.Signal (T, )+import qualified Synthesizer.LLVM.Simple.SignalPacked as SigS import qualified Synthesizer.LLVM.Parameterized.Signal as Sig import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Frame.SerialVector as Serial@@ -33,24 +45,19 @@ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Vector as Vector-import qualified LLVM.Extra.MaybeContinuation as Maybe-import qualified LLVM.Extra.Control as U import qualified LLVM.Extra.Arithmetic as A-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, undefTuple, )+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) -import qualified Types.Data.Num as TypeNum-import Types.Data.Num ((:*:), )+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal ((:*:), ) import qualified LLVM.Core as LLVM import LLVM.Core- (CodeGenFunction, Value, valueOf,+ (CodeGenFunction, Value, IsSized, IsConst, IsArithmetic, IsFloating, IsPrimitive, Vector, SizeOf, ) -import qualified Control.Monad.Trans.Class as MT-import qualified Control.Monad.Trans.State as MS import Control.Monad.HT ((<=<), )-import Control.Monad (replicateM, ) -- we can also use <$> for parameters import Control.Arrow ((^<<), ) import Control.Applicative (liftA2, )@@ -64,173 +71,23 @@ import Data.Int (Int32, ) import Foreign.Storable (Storable, ) -import qualified Data.List as List- import NumericPrelude.Numeric as NP import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, ) -{- |-Convert a signal of scalar values into one using processor vectors.-If the signal length is not divisible by the chunk size,-then the last chunk is dropped.--}-pack, packRotate ::- (Serial.C v, a ~ Serial.Element v) =>- T p a -> T p v-pack = packRotate--packRotate (Cons next start stop createIOContext deleteIOContext) = Cons- (\param s -> do- wInit <- Maybe.lift $ Serial.writeStart- (w2,_,s2) <-- Maybe.fromBool $- U.whileLoop- (valueOf True,- (wInit,- valueOf $ (fromIntegral $ Serial.sizeOfIterator wInit :: Word32),- s))- (\(cont,(_w0,i0,_s0)) ->- A.and cont =<<- A.cmp LLVM.CmpGT i0 A.zero)- (\(_,(w0,i0,s0)) -> Maybe.toBool $ do- (a,s1) <- next param s0- Maybe.lift $ do- w1 <- Serial.writeNext a w0- i1 <- A.dec i0- return (w1,i1,s1))- v <- Maybe.lift $ Serial.writeStop w2- return (v, s2))- start- stop- createIOContext- deleteIOContext--{--We could reformulate it in terms of WriteIterator-that accesses elements using LLVM.extract.-We might move the loop counter into the Iterator,-but we have to assert that the counter is not duplicated.--packIndex ::- (Serial.C v, a ~ Serial.Element v) =>- T p a -> T p v-packIndex (Cons next start createIOContext deleteIOContext) = Cons- (\param s -> do- (v2,_,s2) <-- Maybe.fromBool $- U.whileLoop- (valueOf True, (undefTuple, A.zero, s))- (\(cont,(v0,i0,_s0)) ->- A.and cont =<<- A.cmp LLVM.CmpLT i0- (valueOf $ fromIntegral $ Serial.size v0))- (\(_,(v0,i0,s0)) -> Maybe.toBool $ do- (a,s1) <- next param s0- Maybe.lift $ do- v1 <- Vector.insert i0 a v0- i1 <- A.inc i0- return (v1,i1,s1))- return (v2, s2))- start- createIOContext- deleteIOContext--}---{- |-Like 'pack' but duplicates the code for creating elements.-That is, for vectors of size n, the code of the input signal-will be emitted n times.-This is efficient only for simple input generators.--}-packSmall ::- (Serial.C v, a ~ Serial.Element v) =>- T p a -> T p v-packSmall (Cons next start stop createIOContext deleteIOContext) = Cons- (\param ->- MS.runStateT $- case undefined of- vundef ->- fmap (flip asTypeOf vundef) .- MT.lift . Maybe.lift . Serial.assemble- =<<- replicateM (Serial.size vundef) (MS.StateT $ next param))- start- stop- createIOContext- deleteIOContext---unpack, unpackRotate ::- (Serial.Read v, a ~ Serial.Element v, Memory.C (Serial.ReadIt v)) =>- T p v -> T p a-unpack = unpackRotate--unpackRotate (Cons next start stop createIOContext deleteIOContext) = Cons- (\context (i0,r0,s0) -> do- endOfVector <-- Maybe.lift $ A.cmp LLVM.CmpEQ i0 (valueOf (0::Word32))- (i2,r2,s2) <-- Maybe.fromBool $- U.ifThen endOfVector (valueOf True, (i0,r0,s0)) $ do- (cont1, (v1,s1)) <- Maybe.toBool $ next context s0- r1 <- Serial.readStart v1- return (cont1, (valueOf $ fromIntegral $ Serial.size v1, r1, s1))- Maybe.lift $ do- (a,r3) <- Serial.readNext r2- i3 <- A.dec i2- return (a, (i3,r3,s2)))- (withStart start $ \s -> return (A.zero, undefTuple, s))- (\context (_,_,state) -> stop context state)- createIOContext- deleteIOContext---{--We could reformulate it in terms of ReadIterator-that accesses elements using LLVM.extract.-We might move the loop counter into the Iterator,-but we have to assert that the counter is not duplicated.--unpackIndex ::- (Serial.C v, a ~ Serial.Element v, Memory.C v) =>- T p v -> T p a-unpackIndex (Cons next start createIOContext deleteIOContext) = Cons- (\param (i0,v0,s0) -> do- endOfVector <-- Maybe.lift $ A.cmp LLVM.CmpGE i0- (valueOf $ fromIntegral $ Serial.size v0)- (i2,v2,s2) <-- Maybe.fromBool $- U.ifThen endOfVector (valueOf True, (i0,v0,s0)) $ do- (cont1, (v1,s1)) <- Maybe.toBool $ next param s0- return (cont1, (A.zero, v1, s1))- Maybe.lift $ do- a <- Vector.extract i2 v2- i3 <- A.inc i2- return (a, (i3,v2,s2)))- (\p -> do- s <- start p- let v = undefTuple- return (valueOf $ fromIntegral $ Serial.size v, v, s))- createIOContext- deleteIOContext--}-- withSize ::- (n -> T p (Serial.Value n a)) ->+ (TypeNum.Positive n) =>+ (TypeNum.Singleton n -> T p (Serial.Value n a)) -> T p (Serial.Value n a)-withSize f = f undefined+withSize f = f TypeNum.singleton withSizeRing ::- (Ring.C b, TypeNum.IntegerT n, TypeNum.PositiveT n) =>+ (Ring.C b, TypeNum.Positive n) => (b -> T p (Serial.Value n a)) -> T p (Serial.Value n a) withSizeRing f =- withSize $ \n -> f (fromInteger $ TypeNum.fromIntegerT n)+ withSize $ f . fromInteger . TypeNum.integerFromSingleton constant ::@@ -239,8 +96,8 @@ Memory.FirstClass a, Memory.Stored a ~ am, IsPrimitive a, IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT (n :*: amsize),- TypeNum.PositiveT n) =>+ TypeNum.Positive (n :*: amsize),+ TypeNum.Positive n) => Param.T p a -> T p (Serial.Value n a) constant x = Sig.constant (Serial.replicate ^<< x)@@ -252,15 +109,15 @@ Memory.FirstClass a, Memory.Stored a ~ am, IsPrimitive a, IsSized a, SizeOf a ~ as, IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT (n :*: as),- TypeNum.PositiveT (n :*: amsize),- TypeNum.IntegerT n, TypeNum.PositiveT n) =>+ TypeNum.Positive (n :*: as),+ TypeNum.Positive (n :*: amsize),+ TypeNum.Positive n) => Param.T p a -> Param.T p a -> T p (Serial.Value n a) exponential2 halfLife start = withSizeRing $ \n -> Sig.exponentialCore (Serial.replicate ^<< 0.5 ** (n / halfLife)) (liftA2- (\h -> Serial.fromList . List.iterate (0.5 ** recip h *))+ (\h -> Serial.iteratePlain (0.5 ** recip h *)) halfLife start) exponentialBounded2 ::@@ -269,9 +126,9 @@ Memory.FirstClass a, Memory.Stored a ~ am, IsPrimitive a, IsSized a, SizeOf a ~ as, IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT (n :*: as),- TypeNum.PositiveT (n :*: amsize),- TypeNum.IntegerT n, TypeNum.PositiveT n) =>+ TypeNum.Positive (n :*: as),+ TypeNum.Positive (n :*: amsize),+ TypeNum.Positive n) => Param.T p a -> Param.T p a -> Param.T p a -> T p (Serial.Value n a) exponentialBounded2 bound halfLife start = withSizeRing $ \n ->@@ -279,7 +136,7 @@ (fmap (Serial.replicate) bound) (Serial.replicate ^<< 0.5 ** (n / halfLife)) (liftA2- (\h -> Serial.fromList . List.iterate (0.5 ** recip h *))+ (\h -> Serial.iteratePlain (0.5 ** recip h *)) halfLife start) @@ -288,15 +145,15 @@ Memory.FirstClass t, Memory.Stored t ~ tm, IsPrimitive t, IsSized t, SizeOf t ~ tsize, IsPrimitive tm, IsSized tm, SizeOf tm ~ tmsize,- TypeNum.PositiveT (n :*: tsize),- TypeNum.PositiveT (n :*: tmsize),+ TypeNum.Positive (n :*: tsize),+ TypeNum.Positive (n :*: tmsize), Vector.Real t, IsFloating t, RealField.C t, IsConst t,- TypeNum.IntegerT n, TypeNum.PositiveT n) =>+ TypeNum.Positive n) => Param.T p t -> Param.T p t -> T p (Serial.Value n t) osciCore phase freq = withSizeRing $ \n -> Sig.osciCore (liftA2- (\f -> Serial.fromList . List.iterate (fraction . (f +)))+ (\f -> Serial.iteratePlain (fraction . (f +))) freq phase) (fmap (\f -> Serial.replicate (fraction (n * f)))@@ -308,11 +165,11 @@ Memory.FirstClass t, Memory.Stored t ~ tm, IsPrimitive t, IsSized t, SizeOf t ~ tsize, IsPrimitive tm, IsSized tm, SizeOf tm ~ tmsize,- TypeNum.PositiveT (n :*: tsize),- TypeNum.PositiveT (n :*: tmsize),+ TypeNum.Positive (n :*: tsize),+ TypeNum.Positive (n :*: tmsize), Memory.C cl, Vector.Real t, IsFloating t, RealField.C t, IsConst t,- TypeNum.IntegerT n, TypeNum.PositiveT n) =>+ TypeNum.Positive n) => (forall r. cl -> Serial.Value n t -> CodeGenFunction r y) -> Param.T p c -> Param.T p t -> Param.T p t -> T p y@@ -325,10 +182,10 @@ Memory.FirstClass t, Memory.Stored t ~ tm, IsPrimitive t, IsSized t, SizeOf t ~ tsize, IsPrimitive tm, IsSized tm, SizeOf tm ~ tmsize,- TypeNum.PositiveT (n :*: tsize),- TypeNum.PositiveT (n :*: tmsize),+ TypeNum.Positive (n :*: tsize),+ TypeNum.Positive (n :*: tmsize), Vector.Real t, IsFloating t, RealField.C t, IsConst t,- TypeNum.IntegerT n, TypeNum.PositiveT n) =>+ TypeNum.Positive n) => (forall r. Serial.Value n t -> CodeGenFunction r y) -> Param.T p t -> Param.T p t -> T p y osciSimple wave =@@ -341,15 +198,15 @@ Memory.FirstClass a, Memory.Stored a ~ am, IsPrimitive a, IsSized a, SizeOf a ~ as, IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT (n :*: as),- TypeNum.PositiveT (n :*: amsize),+ TypeNum.Positive (n :*: as),+ TypeNum.Positive (n :*: amsize), IsArithmetic a, SoV.IntegerConstant a,- TypeNum.IntegerT n, TypeNum.PositiveT n) =>+ TypeNum.Positive n) => Param.T p a -> T p (Serial.Value n a) rampSlope slope = withSizeRing $ \n -> Sig.rampCore (fmap (\s -> Serial.replicate (n * s)) slope)- (fmap (\s -> Serial.fromList (List.iterate (s +) 0)) slope)+ (fmap (\s -> Serial.iteratePlain (s +) 0) slope) rampInf dur = rampSlope (recip dur) parabolaFadeInInf dur = withSizeRing $ \n ->@@ -361,11 +218,11 @@ (fmap (\dr -> let d = n / dr- in Serial.fromList $ List.iterate (subtract $ 2 / dr ^ 2) (d*(2-d)))+ in Serial.iteratePlain (subtract $ 2 / dr ^ 2) (d*(2-d))) dur) (fmap (\dr ->- Serial.fromList $ List.map (\t -> t*(2-t)) $ List.iterate (recip dr +) 0)+ Serial.mapPlain (\t -> t*(2-t)) $ Serial.iteratePlain (recip dr +) 0) dur) parabolaFadeOutInf dur = withSizeRing $ \n ->@@ -377,11 +234,11 @@ (fmap (\dr -> let d = n / dr- in Serial.fromList $ List.iterate (subtract $ 2 / dr ^ 2) (-d*d))+ in Serial.iteratePlain (subtract $ 2 / dr ^ 2) (-d*d)) dur) (fmap (\dr ->- Serial.fromList $ List.map (\t -> 1-t*t) $ List.iterate (recip dr +) 0)+ Serial.mapPlain (\t -> 1-t*t) $ Serial.iteratePlain (recip dr +) 0) dur) @@ -390,13 +247,13 @@ -} noise :: (Algebraic.C a, IsFloating a, SoV.IntegerConstant a,- TypeNum.IntegerT n, TypeNum.PositiveT n,- TypeNum.PositiveT (n :*: TypeNum.D32),+ TypeNum.Positive n,+ TypeNum.Positive (n :*: TypeNum.D32), Memory.FirstClass a, Memory.Stored a ~ am, IsPrimitive a, IsSized a, SizeOf a ~ as, IsPrimitive am, IsSized am, SizeOf am ~ amsize,- TypeNum.PositiveT (n :*: as),- TypeNum.PositiveT (n :*: amsize),+ TypeNum.Positive (n :*: as),+ TypeNum.Positive (n :*: amsize), MakeValueTuple a, ValueTuple a ~ (Value a), Storable a) => Param.T p Word32 -> Param.T p a ->@@ -417,19 +274,19 @@ -} int31tofp :: (IsFloating a, IsPrimitive a,- TypeNum.PositiveT n, TypeNum.PositiveT (n :*: TypeNum.D32)) =>+ TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) => Serial.Value n Word32 -> CodeGenFunction r (Serial.Value n a) int31tofp = Serial.mapV $ LLVM.inttofp <=< (LLVM.bitcast ::- (TypeNum.PositiveT n, TypeNum.PositiveT (n :*: TypeNum.D32)) =>+ (TypeNum.Positive n, TypeNum.Positive (n :*: TypeNum.D32)) => Value (Vector n Word32) -> CodeGenFunction r (Value (Vector n Int32))) noiseCore, noiseCoreAlt ::- (TypeNum.IntegerT n, TypeNum.PositiveT n,- TypeNum.PositiveT (n :*: TypeNum.D32)) =>+ (TypeNum.Positive n,+ TypeNum.Positive (n :*: TypeNum.D32)) => Param.T p Word32 -> T p (Serial.Value n Word32) noiseCore seed =
src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs view
@@ -5,25 +5,20 @@ {-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Parameterized.SignalPrivate where +import qualified Synthesizer.LLVM.Simple.Signal as Sig import qualified Synthesizer.LLVM.Parameter as Param import qualified LLVM.Extra.MaybeContinuation as Maybe import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Class as Class-import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C-import qualified LLVM.Core as LLVM import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, ) import Control.Arrow ((&&&), )-import Control.Monad (liftM2, )+import Control.Monad (liftM, liftM2, ) import Control.Applicative (Applicative, pure, (<*>), ) -import Data.Tuple.HT (mapFst)- import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) @@ -97,13 +92,33 @@ -- finalization from IO monad, also run within Unsafe.performIO +instance Sig.C (T p) where+ simple next start =+ Cons+ (\() -> next)+ (const $ fmap ((,) ()) start)+ (const $ const $ return ())+ (const $ return ((), ()))+ (const $ return ())++ alter f (Cons next0 start0 stop0 create delete) =+ case f (Sig.Core next0 return id) of+ Sig.Core next1 start1 stop1 ->+ Cons+ next1+ (withStart start0 start1)+ (\c -> stop0 c . stop1)+ create delete++ withStart ::- (startParam -> CodeGenFunction r (context, state0)) ->- (state0 -> CodeGenFunction r state1) ->- startParam -> CodeGenFunction r (context, state1)+ Monad m =>+ (startParam -> m (context, state0)) ->+ (state0 -> m state1) ->+ startParam -> m (context, state1) withStart start act p = do (c,s) <- start p- fmap ((,) c) $ act s+ liftM ((,) c) $ act s combineStart :: Monad m =>@@ -164,30 +179,29 @@ (const $ return ()) +constant ::+ (Storable a, MakeValueTuple a, ValueTuple a ~ al,+ Memory.C al) =>+ Param.T p a -> T p al+constant =+ simple+ (\pl () -> return (pl, ()))+ (return . flip (,) ())++ map :: (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl) => (forall r. pl -> a -> CodeGenFunction r b) -> Param.T p ph -> T p a -> T p b-map f selectParamF- (Cons next start stop createIOContext deleteIOContext) =- Param.with selectParamF $ \getParamF valueF -> Cons- (\(parameterF, parameter) sa0 -> do- (a,sa1) <- next parameter sa0- b <- Maybe.lift $ f (valueF parameterF) a- return (b, sa1))- (\(parameterF, parameter) ->- fmap (mapFst ((,) parameterF)) $ start parameter)- (stop . snd)- (\p -> do- (ioContext, param) <- createIOContext p- return (ioContext, (getParamF p, param)))- deleteIOContext+map f param =+ Sig.map (uncurry f) . zip (constant param) +-- for backwards compatibility mapSimple :: (forall r. a -> CodeGenFunction r b) -> T p a -> T p b-mapSimple f = map (const f) (return ())+mapSimple = Sig.map zipWith ::@@ -195,33 +209,38 @@ (forall r. pl -> a -> b -> CodeGenFunction r c) -> Param.T p ph -> T p a -> T p b -> T p c-zipWith f selectParamF- (Cons nextA startA stopA createIOContextA deleteIOContextA)- (Cons nextB startB stopB createIOContextB deleteIOContextB) =- Param.with selectParamF $ \getParamF valueParamF -> Cons- (\(parameterF, (parameterA, parameterB)) (sa0,sb0) -> do+zipWith f param as bs =+ map (uncurry . f) param $ zip as bs++zip :: T p a -> T p b -> T p (a,b)+zip (Cons nextA startA stopA createIOContextA deleteIOContextA)+ (Cons nextB startB stopB createIOContextB deleteIOContextB) =+ Cons+ (\(parameterA, parameterB) (sa0,sb0) -> do (a,sa1) <- Maybe.onFail (stopB parameterB sb0) $ nextA parameterA sa0 (b,sb1) <- Maybe.onFail (stopA parameterA sa1) $ nextB parameterB sb0- c <- Maybe.lift $ f (valueParamF parameterF) a b- return (c, (sa1,sb1)))- (\(parameterF, parameter) ->- fmap (mapFst ((,) parameterF)) $- combineStart startA startB parameter)- (combineStop stopA stopB . snd)- (\p -> do- (c,param) <- combineCreate createIOContextA createIOContextB p- return (c, (getParamF p, param)))+ return ((a,b), (sa1,sb1)))+ (combineStart startA startB)+ (combineStop stopA stopB)+ (combineCreate createIOContextA createIOContextB) (combineDelete deleteIOContextA deleteIOContextB) +{-+maintained for backwards compatibility+It is a specialisation of Sig.zipWith.+However, we cannot define zipWithSimple = Sig.zipWith,+since Sig.zipWith depends on Applicative.liftA2,+which depends on zipWithSimple.+-} zipWithSimple :: (forall r. a -> b -> CodeGenFunction r c) -> T p a -> T p b -> T p c-zipWithSimple f =- zipWith (const f) (return ())+zipWithSimple f as bs =+ mapSimple (uncurry f) $ zip as bs instance Functor (T p) where@@ -280,59 +299,3 @@ Maybe.lift $ fmap (\al1 -> (al0,al1)) (f pl al0)) return (param &&& initial)---quantizeNext ::- (LLVM.IsFloating a, LLVM.CmpRet a, LLVM.CmpResult a ~ Bool,- SoV.IntegerConstant a, Phi z,- Class.Undefined y, Phi y,- Class.Undefined state, Phi state) =>- (forall zn. Phi zn => context -> state -> Maybe.T r zn (y, state)) ->- (valueA -> LLVM.Value a) ->- (valueA, context) ->- ((y, state), LLVM.Value a) ->- Maybe.T r z (y, ((y, state), LLVM.Value a))-quantizeNext next valueK (kl,context) yState0 = do- ((y1,state1), frac1) <-- Maybe.fromBool $- C.whileLoop- (LLVM.valueOf True, yState0)- (\(cont1, (_, frac0)) ->- LLVM.and cont1 =<< A.fcmp LLVM.FPOLE frac0 A.zero)- (\(_,((_,state01), frac0)) ->- Maybe.toBool $ liftM2 (,)- (next context state01)- (Maybe.lift $ A.add frac0 (valueK kl)))-- frac2 <- Maybe.lift $ A.sub frac1 A.one- return (y1, ((y1,state1),frac2))--quantizeStart ::- (Monad m, Class.Undefined y, A.Additive al) =>- (param -> m (context, state)) ->- (ap, param) -> m ((ap, context), ((y, state), al))-{- using this initialization code we would not need undefined values- (do sa <- start- (a,_) <- next sa- return (sa, a, A.zero))--}-quantizeStart start (kl,p) = do- (c,s) <- start p- return ((kl,c), ((Class.undefTuple, s), A.zero))--quantizeStop ::- (context -> state -> m ()) ->- (ap, context) -> ((y, state), al) -> m ()-quantizeStop stop (_kl,c) ((_, s), _) = stop c s--quantizeCreate ::- Monad m =>- (p -> m (ioContext, param)) ->- (p -> ah) -> p -> m (ioContext, (ah, param))-quantizeCreate createIOContext getK p = do- (ioContext, param) <- createIOContext p- return (ioContext, (getK p, param))--quantizeDelete :: (ioContext -> m ()) -> (ioContext -> m ())-quantizeDelete deleteIOContext =- deleteIOContext
src/Synthesizer/LLVM/Plug/Input.hs view
@@ -18,7 +18,8 @@ import qualified LLVM.Core as LLVM import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum+import Type.Base.Proxy (Proxy) import Control.Applicative (liftA2, ) @@ -208,11 +209,11 @@ in order to forbid writing to the array. -} controllerSet ::- (TypeNum.NaturalT n,+ (TypeNum.Natural n, Storable a, MakeValueTuple a, ValueTuple a ~ LLVM.Value a, Memory.FirstClass a, LLVM.IsSized a, LLVM.IsSized (Memory.Stored a)) =>- n -> T (PCS.T Int a) (LLVM.Value (LLVM.Array n a))-controllerSet n =+ Proxy n -> T (PCS.T Int a) (LLVM.Value (LLVM.Array n a))+controllerSet pn = case storableVector of Cons next start create delete -> Cons (\((arrPtr, _), param) state0 -> do@@ -244,9 +245,10 @@ bt) -- FIXME: handle memory exhaustion- arr <- Array.mallocArray (TypeNum.fromIntegerT n)+ let n = TypeNum.integralFromProxy pn+ arr <- Array.mallocArray n flip mapM_ (Map.toList $ PCS.initial pcs) $ \(i,a) ->- if i >= TypeNum.fromIntegerT n+ if i >= n then error "Plug.Input.controllerSet: array too small" else pokeElemOff arr i a
src/Synthesizer/LLVM/Random.hs view
@@ -16,11 +16,14 @@ import LLVM.Core (CodeGenFunction, Value, Vector,- zext, trunc, lshr, value, valueOf, vector,+ zext, trunc, lshr, value, valueOf, undef, constOf, constVector, bitcast, ) import qualified LLVM.Core as LLVM-import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum +import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.Empty as Empty+import Data.NonEmpty ((!:), ) import Data.Function.HT (nest, ) import Data.Int (Int32, )@@ -120,18 +123,17 @@ fromIntegral $ nest n next 1 vectorSeed ::- (TypeNum.IntegerT n, TypeNum.PositiveT n) =>+ (TypeNum.Positive n) => Word32 -> Vector n Word32 vectorSeed seed =- let n = Vector.size $ valueOf v- v = vector $ take n $ iterate next seed- in v+ LLVM.cyclicVector $ NonEmptyC.iterate next seed+-- vector $ NonEmptyC.iterate next seed vector64 :: Value (Vector n Word64) -> Value (Vector n Word64) vector64 = id nextVector ::- (TypeNum.PositiveT n) =>+ (TypeNum.Positive n) => Value (Vector n Word32) -> CodeGenFunction r (Value (Vector n Word32)) nextVector s =@@ -152,10 +154,7 @@ CodeGenFunction r (Value (Vector TypeNum.D4 Word32))) nextVector4X86 = Ext.with X86.pmuludq $ \muludq n s -> do- let prepConstFactor x =- value $ constVector [constOf x, undef]-- fac = 2^(31::Int) - modulus+ let fac = 2^(31::Int) - modulus mulAndReduce x = do (low0, high0) <-@@ -167,15 +166,9 @@ muludq (prepConstFactor fac) =<< bitcast high0 - (lowEven, highEven) <-- mulAndReduce =<<- LLVM.shufflevector s (value undef)- (constVector [constOf 0, undef, constOf 2, undef])+ (lowEven, highEven) <- mulAndReduce =<< shuffleHoles s 0 2 - (lowOdd, highOdd) <-- mulAndReduce =<<- LLVM.shufflevector s (value undef)- (constVector [constOf 1, undef, constOf 3, undef])+ (lowOdd, highOdd) <- mulAndReduce =<< shuffleHoles s 1 3 low <- truncAndInterleave2x64to4x32 lowEven lowOdd high <- truncAndInterleave2x64to4x32 highEven highOdd@@ -201,7 +194,7 @@ even4x32 <- bitcast even2x64 odd4x32 <- bitcast odd2x64 Vector.shuffleMatchPlain2 even4x32 odd4x32- (constVector [constOf 0, constOf 4, constOf 2, constOf 6])+ (constVector $ fmap constOf $ 0 !: 4 !: 2 !: 6 !: Empty.Cons) {-@@ -214,13 +207,10 @@ CodeGenFunction r (Value (Vector TypeNum.D2 Word32))) nextVector2X86 = Ext.with X86.pmuludq $ \muludq n s -> do- let prepConstFactor x =- value $ constVector [constOf x, undef] (low0, high0) <- splitVector31to64 =<< muludq (prepConstFactor (vectorParameter n)) =<<- LLVM.shufflevector s (value undef)- (constVector [constOf 0, undef, constOf 1, undef])+ shuffleHoles s 0 1 -- fac = mod (2^31) modulus let fac = 2^(31::Int) - modulus (low1, high1) <-@@ -242,7 +232,7 @@ prodMod64as32 <- bitcast prodMod64 prodMod <- Vector.shuffle (prodMod64as32 :: Value (Vector TypeNum.D4 Word32))- (constVector $ map constOf [0,2])+ (constVector $ fmap constOf $ 0!:2!:Empty.Cons) prodModS <- A.sub prodMod (SoV.replicateOf modulus) -}@@ -259,10 +249,24 @@ LLVM.shufflevector (result :: Value (Vector TypeNum.D4 Word32)) (LLVM.value LLVM.undef)- (constVector $ map constOf [0,2])+ (constVector $ fmap constOf $ 0!:2!:Empty.Cons) +prepConstFactor :: Word32 -> Value (Vector TypeNum.D4 Word32)+prepConstFactor x =+ value $ constVector $+ constOf x !: undef !: constOf x !: undef !: Empty.Cons++shuffleHoles ::+ (TypeNum.Positive n) =>+ Value (Vector n Word32) ->+ Word32 -> Word32 ->+ CodeGenFunction r (Value (Vector TypeNum.D4 Word32))+shuffleHoles s j k =+ LLVM.shufflevector s (value undef)+ (constVector $ constOf j !: undef !: constOf k !: undef !: Empty.Cons)+ splitVector31to64 ::- (TypeNum.PositiveT n) =>+ (TypeNum.Positive n) => Value (Vector n Word64) -> CodeGenFunction r (Value (Vector n Word64), Value (Vector n Word64)) splitVector31to64 x = do@@ -314,7 +318,7 @@ as in the approach that is implemented here. -} nextVectorGeneric ::- (TypeNum.PositiveT n) =>+ (TypeNum.Positive n) => Value (Vector n Word32) -> CodeGenFunction r (Value (Vector n Word32)) nextVectorGeneric s = do@@ -363,7 +367,7 @@ otherwise select corresponding elements from the second vector. -} selectNonNegativeGeneric ::- (TypeNum.PositiveT n) =>+ (TypeNum.Positive n) => Value (Vector n Int32) -> Value (Vector n Int32) -> CodeGenFunction r (Value (Vector n Int32))@@ -373,7 +377,7 @@ splitVector31 ::- (TypeNum.PositiveT n) =>+ (TypeNum.Positive n) => Value (Vector n Word64) -> CodeGenFunction r (Value (Vector n Word32), Value (Vector n Word32)) splitVector31 x = do@@ -386,7 +390,7 @@ but unfortunately calls the expensive __umoddi3. -} nextVector64 ::- (TypeNum.PositiveT n) =>+ (TypeNum.Positive n) => Value (Vector n Word32) -> CodeGenFunction r (Value (Vector n Word32)) nextVector64 s =
src/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs view
@@ -409,9 +409,11 @@ bank = Map.fromAscList $ zip [VoiceMsg.toProgram 0 ..] $ [tineProc, pingProc, filterSawProc, bellNoiseProc,- stringProc, fmStringProc, helixNoiseProc] +++ stringProc, fmStringProc] ++ map makeArc arcs ++ windProc : windPhaserProc :- ([helixed . helixSound, sampled . sampledSound] <*> syllables)+ ([helixed . helixSound, sampled . sampledSound] <*> syllables) +++ helixNoiseProc :+ [] return $ \chan initPgm rate -> arrange
src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs view
@@ -60,7 +60,7 @@ import qualified LLVM.Core as LLVM -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum import qualified Data.Traversable as Trav import Control.Arrow (Arrow, arr, first, second, (&&&), (<<^), (^<<), )
src/Synthesizer/LLVM/Server/CausalPacked/Speech.hs view
@@ -223,6 +223,7 @@ phonemeOe, phonemeOn, phonemeUe,+ phonemeUn, phonemeAe, phonemeE, phonemeI,@@ -257,6 +258,7 @@ phonemeOe = (Filtered Continuous Voiced, "oe") phonemeOn = (Filtered Continuous Voiced, "on") phonemeUe = (Filtered Continuous Voiced, "ue")+phonemeUn = (Filtered Continuous Voiced, "un") phonemeAe = (Filtered Continuous Voiced, "ae") phonemeE = (Filtered Continuous Voiced, "e") phonemeI = (Filtered Continuous Voiced, "i")@@ -338,6 +340,7 @@ phonemeE : phonemeI : phonemeOn :+ phonemeUn : []) ++ (zip [VoiceMsg.toPitch 16 ..] $
src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs view
@@ -11,12 +11,12 @@ import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D -import Synthesizer.LLVM.CausalParameterized.Process (($*), ($<), ($<#), ) import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1 import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR+import Synthesizer.LLVM.Causal.Process (($*), ($<), ($<#), ) import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder@@ -193,7 +193,7 @@ in (Analysis.volumeEuclideanSqr end, end) vowelNames :: [String]-vowelNames = ["a", "e", "i", "o", "on", "u", "oe", "ue", "ae"]+vowelNames = ["a", "e", "i", "o", "on", "u", "un", "oe", "ue", "ae"] tonalNames :: [String] tonalNames = vowelNames ++ ["l", "m", "n", "ng", "r", "j"]
src/Synthesizer/LLVM/Server/CommonPacked.hs view
@@ -15,7 +15,7 @@ import qualified Algebra.Additive as Additive -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum import Control.Arrow (arr, ) @@ -47,7 +47,9 @@ vectorSize :: Int-vectorSize = TypeNum.fromIntegerT (undefined :: VectorSize)+vectorSize =+ TypeNum.integralFromSingleton+ (TypeNum.singleton :: TypeNum.Singleton VectorSize) vectorRate :: Fractional a => SampleRate a -> a vectorRate (SampleRate sampleRate) =
src/Synthesizer/LLVM/Server/Packed/Instrument.hs view
@@ -94,6 +94,7 @@ import qualified Synthesizer.LLVM.CausalParameterized.Functional as F import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Simple.Signal as Sig import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Frame as Frame@@ -106,7 +107,7 @@ import qualified LLVM.Extra.Monad as LM import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM-import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Storable.Signal as SigSt@@ -628,7 +629,7 @@ &&& id tineControlledFnProc index depth vel =- F.withArgs $ \freq ->+ F.withGuidedArgs F.atom $ \freq -> CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2) $&@@ -680,7 +681,7 @@ (Stereo.T VectorValue) (Stereo.T VectorValue) fenderProc fade index depth vel =- F.withArgs $ \stereoFreq ->+ F.withGuidedArgs F.atom $ \stereoFreq -> let {- channel_n_1 :: FuncP p VectorValue VectorValue ->@@ -890,7 +891,7 @@ (Stereo.T VectorValue) (Stereo.T VectorValue) resonantFMSynthProc reson index depth vel =- F.withArgs $ \stereoFreq ->+ F.withGuidedArgs (Stereo.cons F.atom F.atom) $ \stereoFreq -> let -- chan :: FuncP p inp VectorValue -> FuncP p inp VectorValue chan freq = CausalPS.osciSimple WaveL.approxSine2@@ -919,8 +920,7 @@ freq)) &|& freq- in Trav.traverse chan $- Stereo.sequence stereoFreq+ in Trav.traverse chan stereoFreq resonantFMSynth :: IO (Real -> Real ->@@ -1136,10 +1136,10 @@ SigP p (Stereo.T VectorValue) windCore reson fm = CausalP.stereoFromMonoControlled CtrlPS.process- $< SigP.zipWithSimple+ $< Sig.zipWith (MoogL.parameter TypeNum.d8) (piecewiseConstant reson)- (SigP.mapSimple Serial.subsample+ (Sig.map Serial.subsample (frequencyFromBendModulation (frequencyConst 0.2) fm)) $* stereoNoise @@ -1226,7 +1226,7 @@ (UniFilter.lowpass ^<< (CtrlPS.processCtrlRate $# (100::Real))- (\k -> SigP.mapSimple+ (\k -> Sig.map (UniFilterL.parameter (LLVM.valueOf 10)) {- bound control in order to avoid too low resonant frequency, which makes the filter instable -}
src/Synthesizer/LLVM/Simple/Signal.hs view
@@ -24,14 +24,14 @@ import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )-import LLVM.Extra.Control (whileLoop, ifThen, )-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, undefTuple, )+import LLVM.Extra.Control (ifThen, )+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, ) import LLVM.Core (CodeGenFunction, ret, Value, valueOf,- IsSized, IsConst, IsArithmetic, IsFloating,+ IsSized, IsConst, IsArithmetic, Linkage(ExternalLinkage), createNamedFunction) import Control.Monad (liftM2, liftM3, )@@ -87,59 +87,92 @@ (ioContext -> IO ()) -- finalization from IO monad, also run within Unsafe.performIO -simple ::- (Memory.C state) =>- (forall r c.- state -> MaybeCont.T r c (a, state)) ->- (forall r. CodeGenFunction r state) ->- T a-simple next start =- Cons- (const next)- (const start)- (return ())- (const $ return ()) +data Core context initState exitState a =+ forall state.+ (Memory.C state) =>+ Core (forall r c.+ (Phi c) =>+ context ->+ state -> MaybeCont.T r c (a, state))+ -- compute next value+ (forall r.+ initState ->+ CodeGenFunction r state)+ -- initial state+ (state -> exitState)+ -- extract final state for cleanup ++class Applicative signal => C signal where+ simple ::+ (Memory.C state) =>+ (forall r c. state -> MaybeCont.T r c (a, state)) ->+ (forall r. CodeGenFunction r state) ->+ signal a++ alter ::+ (forall context initState exitState.+ Core context initState exitState a0 ->+ Core context initState exitState a1) ->+ signal a0 -> signal a1++instance C T where+ simple next start =+ Cons+ (const next)+ (const start)+ (return ())+ (const $ return ())++ alter f (Cons next0 start0 create delete) =+ case f (Core next0 start0 id) of+ Core next1 start1 _ ->+ Cons next1 start1 create delete++ map ::- (forall r. a -> CodeGenFunction r b) -> T a -> T b-map f (Cons next start createIOContext deleteIOContext) =- Cons+ (C signal) =>+ (forall r. a -> CodeGenFunction r b) -> signal a -> signal b+map f = alter (\(Core next start stop) ->+ Core (\ioContext sa0 -> do (a,sa1) <- next ioContext sa0 b <- MaybeCont.lift $ f a return (b, sa1)) start- createIOContext deleteIOContext+ stop) mapAccum ::- (Memory.C s) =>+ (C signal, Memory.C s) => (forall r. a -> s -> CodeGenFunction r (b,s)) -> (forall r. CodeGenFunction r s) ->- T a -> T b-mapAccum f startS- (Cons next start createIOContext deleteIOContext) =- Cons+ signal a -> signal b+mapAccum f startS = alter (\(Core next start stop) ->+ Core (\ioContext (sa0,ss0) -> do (a,sa1) <- next ioContext sa0 (b,ss1) <- MaybeCont.lift $ f a ss0 return (b, (sa1,ss1))) (\ioContext -> liftM2 (,) (start ioContext) startS)- createIOContext deleteIOContext+ (stop . fst)) zipWith ::- (forall r. a -> b -> CodeGenFunction r c) -> T a -> T b -> T c-zipWith f- (Cons nextA startA createIOContextA deleteIOContextA)- (Cons nextB startB createIOContextB deleteIOContextB) =+ (C signal) =>+ (forall r. a -> b -> CodeGenFunction r c) ->+ signal a -> signal b -> signal c+zipWith f a b = map (uncurry f) $ liftA2 (,) a b++zip :: T a -> T b -> T (a,b)+zip (Cons nextA startA createIOContextA deleteIOContextA)+ (Cons nextB startB createIOContextB deleteIOContextB) = Cons (\(ioContextA, ioContextB) (sa0,sb0) -> do (a,sa1) <- nextA ioContextA sa0 (b,sb1) <- nextB ioContextB sb0- c <- MaybeCont.lift $ f a b- return (c, (sa1,sb1)))+ return ((a,b), (sa1,sb1))) (\(ioContextA, ioContextB) -> liftM2 (,) (startA ioContextA)@@ -151,11 +184,7 @@ deleteIOContextA ca >> deleteIOContextB cb) -zip ::- T a -> T b -> T (a,b)-zip = liftA2 (,) - instance Functor T where fmap f = map (return . f) @@ -164,7 +193,7 @@ -} instance Applicative T where pure x = simple (\() -> return (x, ())) (return ())- (<*>) = zipWith (\f a -> return (f a))+ f <*> a = fmap (uncurry ($)) $ zip f a instance (A.Additive a) => Additive.C (T a) where zero = pure A.zero@@ -195,56 +224,21 @@ fromRational x = pure (A.fromRational' x) (/) = zipWith A.fdiv -{- |-Stretch signal in time by a certain factor.--}-interpolateConstant ::- (Memory.C a,- Memory.FirstClass b, Memory.Stored b ~ bm, IsSized b, IsSized bm,- SoV.IntegerConstant b,- IsFloating b, LLVM.CmpRet b, LLVM.CmpResult b ~ Bool) =>- b -> T a -> T a-interpolateConstant k- (Cons next start createIOContext deleteIOContext) =- Cons- (\ioContext ((y0,state0),ss0) ->- do ((y1,state1), ss1) <-- MaybeCont.fromBool $- whileLoop- (valueOf True, ((y0,state0), ss0))- (\(cont1, (_, ss1)) ->- LLVM.and cont1 =<< A.fcmp LLVM.FPOLE ss1 A.zero)- (\(_, ((_,state01), ss1)) ->- MaybeCont.toBool $ liftM2 (,)- (next ioContext state01)- (MaybeCont.lift $ A.add ss1 (valueOf k))) - ss2 <- MaybeCont.lift $ A.sub ss1 A.one- return (y1, ((y1,state1),ss2)))--{- using this initialization code we would not need undefined values- (do sa <- start- (a,_) <- next sa- return (sa, a, A.zero))--}- (fmap (\sa -> ((undefTuple, sa), A.zero)) . start)- createIOContext deleteIOContext-- mix ::- (A.Additive a) =>- T a -> T a -> T a+ (C signal, A.Additive a) =>+ signal a -> signal a -> signal a mix = zipWith Frame.mix envelope ::- (A.PseudoRing a) =>- T a -> T a -> T a+ (C signal, A.PseudoRing a) =>+ signal a -> signal a -> signal a envelope = zipWith Frame.amplifyMono envelopeStereo ::- (A.PseudoRing a) =>- T a -> T (Stereo.T a) -> T (Stereo.T a)+ (C signal, A.PseudoRing a) =>+ signal a -> signal (Stereo.T a) -> signal (Stereo.T a) envelopeStereo = zipWith Frame.amplifyStereo amplify ::@@ -262,7 +256,7 @@ iterate ::- (Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, IsConst a) =>+ (Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, IsConst a) => (forall r. Value a -> CodeGenFunction r (Value a)) -> Value a -> T (Value a) iterate f initial =@@ -272,14 +266,14 @@ exponential2 :: (Trans.C a, IsArithmetic a,- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am, IsConst a) =>+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, IsConst a) => a -> a -> T (Value a) exponential2 halfLife = iterate (\y -> A.mul y (valueOf (0.5 ** recip halfLife))) . valueOf osciPlain ::- (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,+ (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm, SoV.Fraction t, IsConst t) => (forall r. Value t -> CodeGenFunction r y) -> Value t -> Value t -> T y@@ -289,7 +283,7 @@ phase osci ::- (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm,+ (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm, SoV.Fraction t, IsConst t) => (forall r. Value t -> CodeGenFunction r y) -> t -> t -> T y@@ -298,7 +292,7 @@ osciSaw :: (SoV.IntegerConstant a,- Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,+ Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, SoV.Fraction a, IsConst a) => a -> a -> T (Value a) osciSaw = osci Wave.saw
+ src/Synthesizer/LLVM/Simple/SignalPacked.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+module Synthesizer.LLVM.Simple.SignalPacked where++import Synthesizer.LLVM.Simple.Signal (Core(Core), )+import qualified Synthesizer.LLVM.Simple.Signal as Sig+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.Control as U+import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Class (undefTuple, )++import qualified LLVM.Core as LLVM+import LLVM.Core (valueOf, )++import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS+import Control.Monad (replicateM, )++import Data.Word (Word32, )++import NumericPrelude.Numeric as NP+import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )++++{- |+Convert a signal of scalar values into one using processor vectors.+If the signal length is not divisible by the chunk size,+then the last chunk is dropped.+-}+pack, packRotate ::+ (Sig.C signal, Serial.C v, a ~ Serial.Element v) =>+ signal a -> signal v+pack = packRotate++packRotate = Sig.alter (\(Core next start stop) -> Core+ (\param s -> do+ wInit <- Maybe.lift $ Serial.writeStart+ (w2,_,s2) <-+ Maybe.fromBool $+ U.whileLoop+ (valueOf True,+ (wInit,+ valueOf $ (fromIntegral $ Serial.sizeOfIterator wInit :: Word32),+ s))+ (\(cont,(_w0,i0,_s0)) ->+ A.and cont =<<+ A.cmp LLVM.CmpGT i0 A.zero)+ (\(_,(w0,i0,s0)) -> Maybe.toBool $ do+ (a,s1) <- next param s0+ Maybe.lift $ do+ w1 <- Serial.writeNext a w0+ i1 <- A.dec i0+ return (w1,i1,s1))+ v <- Maybe.lift $ Serial.writeStop w2+ return (v, s2))+ start+ stop)++{-+We could reformulate it in terms of WriteIterator+that accesses elements using LLVM.extract.+We might move the loop counter into the Iterator,+but we have to assert that the counter is not duplicated.++packIndex ::+ (Sig.C signal, Serial.C v, a ~ Serial.Element v) =>+ signal a -> signal v+packIndex = Sig.alter (\(Core next start stop) -> Core+ (\param s -> do+ (v2,_,s2) <-+ Maybe.fromBool $+ U.whileLoop+ (valueOf True, (undefTuple, A.zero, s))+ (\(cont,(v0,i0,_s0)) ->+ A.and cont =<<+ A.cmp LLVM.CmpLT i0+ (valueOf $ fromIntegral $ Serial.size v0))+ (\(_,(v0,i0,s0)) -> Maybe.toBool $ do+ (a,s1) <- next param s0+ Maybe.lift $ do+ v1 <- Vector.insert i0 a v0+ i1 <- A.inc i0+ return (v1,i1,s1))+ return (v2, s2))+ start+ stop)+-}+++{- |+Like 'pack' but duplicates the code for creating elements.+That is, for vectors of size n, the code of the input signal+will be emitted n times.+This is efficient only for simple input generators.+-}+packSmall ::+ (Sig.C signal, Serial.C v, a ~ Serial.Element v) =>+ signal a -> signal v+packSmall = Sig.alter (\(Core next start stop) -> Core+ (\param ->+ MS.runStateT $+ Serial.withSize $ \n ->+ MT.lift . Maybe.lift . Serial.assemble+ =<<+ replicateM n (MS.StateT $ next param))+ start+ stop)+++unpack, unpackRotate ::+ (Sig.C signal,+ Serial.Read v, a ~ Serial.Element v, Serial.ReadIt v ~ itv, Memory.C itv) =>+ signal v -> signal a+unpack = unpackRotate++unpackRotate = Sig.alter (\(Core next start stop) -> Core+ (\context (i0,r0,s0) -> do+ endOfVector <-+ Maybe.lift $ A.cmp LLVM.CmpEQ i0 (valueOf (0::Word32))+ (i2,r2,s2) <-+ Maybe.fromBool $+ U.ifThen endOfVector (valueOf True, (i0,r0,s0)) $ do+ (cont1, (v1,s1)) <- Maybe.toBool $ next context s0+ r1 <- Serial.readStart v1+ return (cont1, (valueOf $ fromIntegral $ Serial.size v1, r1, s1))+ Maybe.lift $ do+ (a,r3) <- Serial.readNext r2+ i3 <- A.dec i2+ return (a, (i3,r3,s2)))+ (fmap (\s -> (A.zero, undefTuple, s)) . start)+ (\(_,_,state) -> stop state))+++{-+We could reformulate it in terms of ReadIterator+that accesses elements using LLVM.extract.+We might move the loop counter into the Iterator,+but we have to assert that the counter is not duplicated.++unpackIndex ::+ (Serial.C v, a ~ Serial.Element v, Memory.C v) =>+ signal v -> signal a+unpackIndex = Sig.alter (\(Core next start stop) -> Core+ (\param (i0,v0,s0) -> do+ endOfVector <-+ Maybe.lift $ A.cmp LLVM.CmpGE i0+ (valueOf $ fromIntegral $ Serial.size v0)+ (i2,v2,s2) <-+ Maybe.fromBool $+ U.ifThen endOfVector (valueOf True, (i0,v0,s0)) $ do+ (cont1, (v1,s1)) <- Maybe.toBool $ next param s0+ return (cont1, (A.zero, v1, s1))+ Maybe.lift $ do+ a <- Vector.extract i2 v2+ i3 <- A.inc i2+ return (a, (i3,v2,s2)))+ (\p -> do+ s <- start p+ let v = undefTuple+ return (valueOf $ fromIntegral $ Serial.size v, v, s))+ stop)+-}
src/Synthesizer/LLVM/Simple/Value.hs view
@@ -9,7 +9,7 @@ twoPi, square, sqrt, max, min, limit, fraction, - (%==), (%/=), (%<), (%<=), (%>), (%>=),+ (%==), (%/=), (%<), (%<=), (%>), (%>=), not, (%&&), (%||), (?), (??), @@ -64,7 +64,7 @@ import qualified Prelude as P import NumericPrelude.Numeric hiding (pi, sqrt, fromRational', fraction, )-import NumericPrelude.Base hiding (min, max, unzip, unzip3, )+import NumericPrelude.Base hiding (min, max, unzip, unzip3, not, ) {-@@ -304,6 +304,10 @@ -- | Lazy OR (%||) :: T (LLVM.Value Bool) -> T (LLVM.Value Bool) -> T (LLVM.Value Bool) a %|| b = a ? (constant True, b)++not :: T (LLVM.Value Bool) -> T (LLVM.Value Bool)+not = lift1 LLVM.inv+ infix 0 ? {- |
src/Synthesizer/LLVM/Storable/Process.hs view
@@ -27,7 +27,7 @@ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Core as LLVM import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )-import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal as TypeNum import qualified Control.Arrow as Arr import qualified Data.Foldable as Fold@@ -56,7 +56,7 @@ (EventListTT.T NonNeg.Int (SV.Vector a)) (SV.Vector a)) makeArranger = do- mixer <- SigStL.makeMixer undefined+ mixer <- SigStL.makeMixer A.add fill <- SigStL.fillBuffer A.zero return $ Arr.arr $ \ now -> let -- summation is done twice, for 'sz' and for 'xs'@@ -81,7 +81,7 @@ continuePacked ::- (CutG.Transform a, Storable b, LLVM.IsPrimitive b, TypeNum.PositiveT n) =>+ (CutG.Transform a, Storable b, LLVM.IsPrimitive b, TypeNum.Positive n) => PIO.T a (SV.Vector (Serial.Plain n b)) -> (b -> PIO.T a (SV.Vector (Serial.Plain n b))) -> PIO.T a (SV.Vector (Serial.Plain n b))
src/Synthesizer/LLVM/Storable/Signal.hs view
@@ -39,11 +39,14 @@ import LLVM.Extra.Arithmetic (advanceArrayElementPtr, ) import LLVM.Extra.Control (arrayLoop, ) import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )++import qualified LLVM.Core as LLVM import LLVM.Core (Linkage(ExternalLinkage), createNamedFunction, ret, IsPrimitive, getElementPtr, )-import qualified Types.Data.Num as TypeNum +import qualified Type.Data.Num.Decimal as TypeNum+ import qualified Control.Category as Cat import qualified Data.List.HT as ListHT@@ -69,34 +72,38 @@ It would also need copying since the source data may not be aligned properly. -} unpackStrict ::- (Storable a, IsPrimitive a, TypeNum.PositiveT n) =>+ (Storable a, IsPrimitive a, TypeNum.Positive n) => SV.Vector (Serial.Plain n a) -> SV.Vector a unpackStrict v =- let getDim :: (TypeNum.PositiveT n) => SV.Vector (Serial.Plain n a) -> n -> Int- getDim _ = TypeNum.fromIntegerT- d = getDim v undefined+ let getDim ::+ (TypeNum.Positive n) =>+ SV.Vector (Serial.Plain n a) -> TypeNum.Singleton n -> Int+ getDim _ = TypeNum.integralFromSingleton+ d = getDim v TypeNum.singleton (fptr,s,l) = SVB.toForeignPtr v in SVB.SV (castForeignPtr fptr) (s*d) (l*d) unpack ::- (Storable a, IsPrimitive a, TypeNum.PositiveT n) =>+ (Storable a, IsPrimitive a, TypeNum.Positive n) => SVL.Vector (Serial.Plain n a) -> SVL.Vector a unpack = SVL.fromChunks . map unpackStrict . SVL.chunks unpackStereoStrict ::- (Storable a, IsPrimitive a, TypeNum.PositiveT n) =>+ (Storable a, IsPrimitive a, TypeNum.Positive n) => SV.Vector (StereoVector.T n a) -> SV.Vector (Stereo.T a) unpackStereoStrict v =- let getDim :: (TypeNum.PositiveT n) => SV.Vector (StereoVector.T n a) -> n -> Int- getDim _ = TypeNum.fromIntegerT- d = getDim v undefined+ let getDim ::+ (TypeNum.Positive n) =>+ SV.Vector (StereoVector.T n a) -> TypeNum.Singleton n -> Int+ getDim _ = TypeNum.integralFromSingleton+ d = getDim v TypeNum.singleton (fptr,s,l) = SVB.toForeignPtr v in SVB.SV (castForeignPtr fptr) (s*d) (l*d) unpackStereo ::- (Storable a, IsPrimitive a, TypeNum.PositiveT n) =>+ (Storable a, IsPrimitive a, TypeNum.Positive n) => SVL.Vector (StereoVector.T n a) -> SVL.Vector (Stereo.T a) unpackStereo = SVL.fromChunks . map unpackStereoStrict . SVL.chunks@@ -117,10 +124,11 @@ IO (SV.Vector v -> SV.Vector a) makeUnpackGenericStrict = let vectorSize ::- (Serial.C vl, n ~ Serial.Size vl, al ~ Serial.Element vl, Storable v, MakeValueTuple v, ValueTuple v ~ vl) =>- SV.Vector v -> n- vectorSize _ = undefined- in fmap (\f v -> f (TypeNum.fromIntegerT (vectorSize v) * SV.length v) v) $+ (Serial.C vl, n ~ Serial.Size vl, al ~ Serial.Element vl,+ Storable v, MakeValueTuple v, ValueTuple v ~ vl) =>+ SV.Vector v -> TypeNum.Singleton n+ vectorSize _ = TypeNum.singleton+ in fmap (\f v -> f (TypeNum.integralFromSingleton (vectorSize v) * SV.length v) v) $ SigP.run (SigPS.unpack $ SigP.fromStorableVector Cat.id) makeUnpackGeneric ::@@ -135,12 +143,12 @@ makeReverser ::- (Storable a, Serial.C value,- MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>- value -> IO (Word32 -> Ptr a -> Ptr a -> IO ())+ (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>+ (value -> LLVM.CodeGenFunction () value) ->+ IO (Word32 -> Ptr a -> Ptr a -> IO ()) -- (Memory.C a struct, Serial.C a) => -- IO (Word32 -> Ptr struct -> Ptr struct -> IO ())-makeReverser dummy =+makeReverser rev = fmap (\f len srcPtr dstPtr -> f len (Memory.castStorablePtr srcPtr) (Memory.castStorablePtr dstPtr)) $ fmap derefMixPtr $@@ -150,8 +158,7 @@ _ <- arrayLoop size ptrB ptrAEnd $ \ ptrBi ptrAj0 -> do ptrAj1 <- getElementPtr ptrAj0 (-1 :: Int32, ()) flip Memory.store ptrBi- =<< Serial.reverse- . flip asTypeOf dummy+ =<< rev =<< Memory.load ptrAj1 return ptrAj1 ret ()@@ -161,7 +168,7 @@ MakeValueTuple v, ValueTuple v ~ vv, Memory.C vv) => IO (SV.Vector v -> SV.Vector v) makeReversePackedStrict = do- rev <- makeReverser undefined+ rev <- makeReverser Serial.reverse return $ \v -> Unsafe.performIO $ SVB.withStartPtr v $ \ptrA len ->@@ -201,7 +208,7 @@ (\body l -> SVL.append body (y l)) x continuePacked ::- (TypeNum.PositiveT n, Storable a, IsPrimitive a) =>+ (TypeNum.Positive n, Storable a, IsPrimitive a) => SVL.Vector (Serial.Plain n a) -> (a -> SVL.Vector (Serial.Plain n a)) -> SVL.Vector (Serial.Plain n a)@@ -286,10 +293,10 @@ Exec.Importer (Word32 -> Ptr a -> Ptr a -> IO ()) makeMixer ::- (Storable a, A.Additive value,- MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>- value -> IO (Word32 -> Ptr a -> Ptr a -> IO ())-makeMixer dummy =+ (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>+ (value -> value -> LLVM.CodeGenFunction () value) ->+ IO (Word32 -> Ptr a -> Ptr a -> IO ())+makeMixer add = fmap (\f len srcPtr dstPtr -> f len (Memory.castStorablePtr srcPtr) (Memory.castStorablePtr dstPtr)) $ fmap derefMixPtr $@@ -297,7 +304,7 @@ createNamedFunction ExternalLinkage "mix" $ \ size srcPtr dstPtr -> do _ <- arrayLoop size srcPtr dstPtr $ \ srcPtri dstPtri -> do y <- Memory.load srcPtri- Memory.modify (A.add (y `asTypeOf` dummy)) dstPtri+ Memory.modify (add y) dstPtri advanceArrayElementPtr dstPtri ret () @@ -326,7 +333,7 @@ EventList.T NonNeg.Int (SVL.Vector a) -> SVL.Vector a) makeArranger = do- mixer <- makeMixer undefined+ mixer <- makeMixer A.add fill <- fillBuffer A.zero return $ \ (SVL.ChunkSize sz) -> let sznn = NonNeg.fromNumberMsg "arrange" sz
synthesizer-llvm.cabal view
@@ -1,5 +1,5 @@ Name: synthesizer-llvm-Version: 0.6+Version: 0.7 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -36,8 +36,7 @@ You should better load the according module into GHCi and play around with it. Stability: Experimental-Tested-With: GHC==6.10.4, GHC==6.12.3-Tested-With: GHC==7.0.4, GHC==7.2.1, GHC==7.4.1, GHC==7.6.3+Tested-With: GHC==7.4.1, GHC==7.6.3, GHC==7.8.1 Cabal-Version: >=1.14 Build-Type: Simple @@ -45,10 +44,6 @@ description: Build example executables default: False -Flag buildTests- description: Build test suite- default: False- Flag alsa description: Build ALSA synthesizer if examples are built default: True@@ -58,7 +53,7 @@ default: True Source-Repository this- Tag: 0.6+ Tag: 0.7 Type: darcs Location: http://code.haskell.org/synthesizer/llvm/ @@ -69,28 +64,28 @@ Library Build-Depends:- llvm-extra >=0.5 && <0.6,+ llvm-extra >=0.6 && <0.7, -- llvm must be imported with restrictive version bounds, -- because we import implicitly and unqualified- llvm-tf >=3.0 && <3.0.1,- tfp >=0.7 && <0.9,+ llvm-tf >=3.0.3 && <3.0.4,+ tfp >=1.0 && <1.1, vault >=0.1 && <0.3,- synthesizer-core >=0.7 && <0.8,+ synthesizer-core >=0.7.1 && <0.8, synthesizer-midi >=0.6 && <0.7, midi >=0.2.1 && <0.3,- storable-record >=0.0.2 && <0.1,+ storable-record >=0.0.3 && <0.1, storable-tuple >=0.0.2 && <0.1, sox >=0.2 && <0.3, storablevector >=0.2.6 && <0.3, unsafe >=0.0 && <0.1, numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2,- non-empty >=0.2 && <0.3,+ non-empty >=0.2.1 && <0.3, event-list >=0.1 && <0.2, filepath >=1.1 && <1.4, random >=1.0 && <1.1, containers >=0.1 && <0.6,- transformers >=0.2 && <0.4,+ transformers >=0.2 && <0.5, utility-ht >=0.0.10 && <0.1 Build-Depends:@@ -107,6 +102,7 @@ Hs-source-dirs: src Exposed-Modules: Synthesizer.LLVM.Simple.Signal+ Synthesizer.LLVM.Simple.SignalPacked Synthesizer.LLVM.Simple.Value Synthesizer.LLVM.Simple.Vanilla Synthesizer.LLVM.Parameterized.Signal@@ -117,6 +113,7 @@ Synthesizer.LLVM.Storable.Process Synthesizer.LLVM.Causal.Process Synthesizer.LLVM.Causal.ProcessValue+ Synthesizer.LLVM.Causal.ProcessPacked Synthesizer.LLVM.CausalParameterized.Process Synthesizer.LLVM.CausalParameterized.ProcessValue Synthesizer.LLVM.CausalParameterized.ProcessPacked@@ -199,7 +196,7 @@ event-list >=0.1 && <0.2, random >=1.0 && <1.1, containers >=0.1 && <0.6,- transformers >=0.2 && <0.4,+ transformers, non-empty >=0.2 && <0.3, utility-ht, filepath,@@ -241,7 +238,7 @@ event-list >=0.1 && <0.2, filepath >=1.1 && <1.4, containers >=0.1 && <0.6,- transformers >=0.2 && <0.4,+ transformers, utility-ht, synthesizer-alsa >=0.5 && <0.6,@@ -295,7 +292,7 @@ event-list >=0.1 && <0.2, filepath >=1.1 && <1.4, containers >=0.1 && <0.6,- transformers >=0.2 && <0.4,+ transformers, utility-ht, base >=4 && <5@@ -337,7 +334,7 @@ event-list >=0.1 && <0.2, filepath >=1.1 && <1.4, containers >=0.1 && <0.6,- transformers >=0.2 && <0.4,+ transformers, utility-ht, base >=4 && <5@@ -400,24 +397,22 @@ Default-Extensions: CPP Main-Is: src/Synthesizer/LLVM/Server/CausalPacked/SpeechExplore.hs -Executable synthi-llvm-test- If flag(buildTests)- Build-Depends:- synthesizer-llvm,+Test-Suite synthi-llvm-test+ Type: exitcode-stdio-1.0+ Build-Depends:+ synthesizer-llvm, - llvm-extra,- llvm-tf,- tfp,- synthesizer-core,- storablevector >=0.2.6 && <0.3,- numeric-prelude >=0.3 && <0.5,- random >=1.0 && <1.1,- utility-ht,+ llvm-extra,+ llvm-tf,+ tfp,+ synthesizer-core,+ storablevector >=0.2.6 && <0.3,+ numeric-prelude >=0.3 && <0.5,+ random >=1.0 && <1.1,+ utility-ht, - QuickCheck >=1 && <3,- base >=4 && <5- Else- Buildable: False+ QuickCheck >=1 && <3,+ base >=4 && <5 Default-Language: Haskell98 GHC-Options: -Wall If impl(ghc>=7.0)
testsuite/Test/Synthesizer/LLVM/Filter.hs view
@@ -25,6 +25,7 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Simple.Signal as Sig import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ) import Synthesizer.LLVM.Parameter (($#), ) @@ -56,12 +57,13 @@ import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Memory as Memory -import LLVM.Core (Value, ) import qualified LLVM.Core as LLVM-import qualified Types.Data.Bool as TypeBool-import qualified Types.Data.Num as TypeNum-import Types.Data.Num (D4, )+import LLVM.Core (Value, ) +import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D4, )+import Type.Base.Proxy (Proxy, )+ import qualified Number.Complex as Complex import qualified Synthesizer.LLVM.Frame.Stereo as Stereo @@ -98,13 +100,13 @@ SigP.T p a lfoSine f reduct = SigP.interpolateConstant reduct $- SigP.mapSimple f $+ Sig.map f $ CausalP.apply (CausalP.mapExponential 2 0.01) $ SigP.osciSimple Wave.sine 0 (fmap (* (0.1/44100)) reduct) allpassControl ::- (TypeNum.NaturalT n) =>- n ->+ (TypeNum.Natural n) =>+ Proxy n -> Param.T p Float -> SigP.T p (Allpass.CascadeParameter n (Value Float)) allpassControl order =@@ -121,7 +123,7 @@ allpassPhaserPipeline reduct xs = let order = TypeNum.d16- in (SigP.drop $# TypeNum.fromIntegerT order) $+ in (SigP.drop $# TypeNum.integralFromProxy order) $ (Allpass.phaserPipeline $< allpassControl order reduct $* xs)@@ -151,7 +153,7 @@ applyPacked proc cs xs = proc $< ((SigP.interpolateConstant $#- (recip $ TypeNum.fromIntegerT TypeNum.d4 :: Float)) cs)+ (recip $ TypeNum.integralFromProxy TypeNum.d4 :: Float)) cs) $* xs @@ -395,8 +397,8 @@ moogCausal ::- (TypeNum.NaturalT n, TypeNum.IsNatural n ~ TypeBool.True) =>- n ->+ (TypeNum.Natural n) =>+ Proxy n -> Param.T p Float -> SigP.T p (Value Float) -> SigP.T p (Value Float)@@ -428,7 +430,7 @@ (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p) in checkSimilarityState 1e-2 limitFloat (moogCausal order reduct tone)- (\p -> moogCore (TypeNum.fromIntegerT order) (Param.get reduct p) (toneS p))+ (\p -> moogCore (TypeNum.integralFromProxy order) (Param.get reduct p) (toneS p)) complexCausal ::
testsuite/Test/Synthesizer/LLVM/Packed.hs view
@@ -8,8 +8,8 @@ import qualified Synthesizer.LLVM.Wave as Wave import qualified Synthesizer.LLVM.Parameter as Param -import Types.Data.Num (D4, )-import qualified Types.Data.Num as TypeNum+import Type.Data.Num.Decimal (D4, )+import qualified Type.Data.Num.Decimal as TypeNum import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Generator.Exponential2 as Exp@@ -141,7 +141,7 @@ (Exp.causalP start <<< CausalP.mapSimple Exp.parameter $* SigP.interpolateConstant- (TypeNum.fromIntegerT TypeNum.d4 :: Param.T p Float)+ (TypeNum.integralFromProxy TypeNum.d4 :: Param.T p Float) lfo) (SigPS.unpack (Exp.causalPackedP start <<<