synthesizer-llvm (empty) → 0.2
raw patch · 53 files changed
+14228/−0 lines, 53 filesdep +HListdep +QuickCheckdep +alsa-pcmsetup-changed
Dependencies added: HList, QuickCheck, alsa-pcm, alsa-seq, base, containers, event-list, functional-arrow, llvm-extra, llvm-ht, midi, non-negative, numeric-prelude, random, sample-frame, sample-frame-np, sox, storable-record, storable-tuple, storablevector, synthesizer-alsa, synthesizer-core, transformers, type-level, utility-ht
Files
- LICENSE +0/−0
- Setup.lhs +3/−0
- src/Synthesizer/LLVM/ALSA/BendModulation.hs +122/−0
- src/Synthesizer/LLVM/ALSA/MIDI.hs +290/−0
- src/Synthesizer/LLVM/Causal/Process.hs +370/−0
- src/Synthesizer/LLVM/CausalParameterized/Controlled.hs +163/−0
- src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs +149/−0
- src/Synthesizer/LLVM/CausalParameterized/Process.hs +860/−0
- src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs +206/−0
- src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs +258/−0
- src/Synthesizer/LLVM/EventIterator.hs +69/−0
- src/Synthesizer/LLVM/Execution.hs +97/−0
- src/Synthesizer/LLVM/Filter/Allpass.hs +348/−0
- src/Synthesizer/LLVM/Filter/Butterworth.hs +109/−0
- src/Synthesizer/LLVM/Filter/Chebyshev.hs +130/−0
- src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs +126/−0
- src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs +153/−0
- src/Synthesizer/LLVM/Filter/FirstOrder.hs +249/−0
- src/Synthesizer/LLVM/Filter/Moog.hs +184/−0
- src/Synthesizer/LLVM/Filter/SecondOrder.hs +336/−0
- src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs +156/−0
- src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs +118/−0
- src/Synthesizer/LLVM/Filter/Universal.hs +163/−0
- src/Synthesizer/LLVM/Frame/Stereo.hs +124/−0
- src/Synthesizer/LLVM/Generator/Exponential2.hs +303/−0
- src/Synthesizer/LLVM/Parameter.hs +186/−0
- src/Synthesizer/LLVM/Parameterized/Signal.hs +819/−0
- src/Synthesizer/LLVM/Parameterized/SignalPacked.hs +364/−0
- src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs +147/−0
- src/Synthesizer/LLVM/Parameterized/Value.hs +133/−0
- src/Synthesizer/LLVM/Random.hs +379/−0
- src/Synthesizer/LLVM/Sample.hs +187/−0
- src/Synthesizer/LLVM/Server.hs +57/−0
- src/Synthesizer/LLVM/Server/Common.hs +153/−0
- src/Synthesizer/LLVM/Server/Packed/Instrument.hs +1494/−0
- src/Synthesizer/LLVM/Server/Packed/Run.hs +422/−0
- src/Synthesizer/LLVM/Server/Packed/Test.hs +680/−0
- src/Synthesizer/LLVM/Server/Scalar/Instrument.hs +199/−0
- src/Synthesizer/LLVM/Server/Scalar/Run.hs +123/−0
- src/Synthesizer/LLVM/Server/Scalar/Test.hs +78/−0
- src/Synthesizer/LLVM/Simple/Signal.hs +436/−0
- src/Synthesizer/LLVM/Simple/Value.hs +234/−0
- src/Synthesizer/LLVM/Simple/Vanilla.hs +111/−0
- src/Synthesizer/LLVM/Storable/ChunkIterator.hs +75/−0
- src/Synthesizer/LLVM/Storable/LazySizeIterator.hs +53/−0
- src/Synthesizer/LLVM/Storable/Signal.hs +353/−0
- src/Synthesizer/LLVM/Test.hs +1288/−0
- src/Synthesizer/LLVM/Wave.hs +193/−0
- src/Test/Main.hs +22/−0
- src/Test/Synthesizer/LLVM/Filter.hs +501/−0
- src/Test/Synthesizer/LLVM/Packed.hs +201/−0
- src/Test/Synthesizer/LLVM/Utility.hs +101/−0
- synthesizer-llvm.cabal +153/−0
+ LICENSE view
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Synthesizer/LLVM/ALSA/BendModulation.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{- |+Various LLVM related instances of the BendModulation type.+I have setup a separate module since these instances are orphan+and need several language extensions.+-}+module Synthesizer.LLVM.ALSA.BendModulation where++import Synthesizer.PiecewiseConstant.ALSA.MIDI+ (BendModulation(BendModulation), )+++import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Control as C+import qualified LLVM.Util.Loop as Loop+import qualified LLVM.Core as LLVM++import Foreign.Storable (Storable(sizeOf, alignment, peek, poke), )+import Foreign.Storable.Traversable as Store++import qualified Control.Applicative as App+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav++import Control.Applicative (Applicative, (<*>), pure, liftA2, )+import qualified Data.TypeLevel.Num as TypeNum++++-- 'fmap' is lazy which is important for the Store functions+instance Functor BendModulation where+ {-# INLINE fmap #-}+ fmap f ~(BendModulation b m) = BendModulation (f b) (f m)++-- useful for defining Additive instance+instance Applicative BendModulation where+ {-# INLINE pure #-}+ pure a = BendModulation a a+ {-# INLINE (<*>) #-}+ ~(BendModulation fb fm) <*> ~(BendModulation b m) =+ BendModulation (fb b) (fm m)++instance Fold.Foldable BendModulation where+ {-# INLINE foldMap #-}+ foldMap = Trav.foldMapDefault++-- this allows for kinds of generic programming+instance Trav.Traversable BendModulation where+ {-# INLINE sequenceA #-}+ sequenceA ~(BendModulation b m) =+ liftA2 BendModulation b m+++instance (Storable a) => Storable (BendModulation a) where+ {-# INLINE sizeOf #-}+ sizeOf = Store.sizeOf+ {-# INLINE alignment #-}+ alignment = Store.alignment+ {-# INLINE peek #-}+ peek = Store.peekApplicative+ {-# INLINE poke #-}+ poke = Store.poke+++instance (Class.Zero a) => Class.Zero (BendModulation a) where+ zeroTuple = Class.zeroTuplePointed++instance (LLVM.ValueTuple a) => LLVM.ValueTuple (BendModulation a) where+ buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)++instance LLVM.IsTuple a => LLVM.IsTuple (BendModulation a) where+ tupleDesc = Class.tupleDescFoldable++instance (LLVM.Undefined a) => LLVM.Undefined (BendModulation a) where+ undefTuple = Class.undefTuplePointed++instance (C.Select a) => C.Select (BendModulation a) where+ select = C.selectTraversable++instance LLVM.CmpRet a b =>+ LLVM.CmpRet (BendModulation a) (BendModulation b) where++instance LLVM.MakeValueTuple h l =>+ LLVM.MakeValueTuple (BendModulation h) (BendModulation l) where+ valueTupleOf = Class.valueTupleOfFunctor++memory ::+ (Rep.Memory l s, LLVM.IsSized s ss) =>+ Rep.MemoryRecord r (LLVM.Struct (s, (s, ()))) (BendModulation l)+memory =+ liftA2 BendModulation+ (Rep.memoryElement (\(BendModulation b _) -> b) TypeNum.d0)+ (Rep.memoryElement (\(BendModulation _ m) -> m) TypeNum.d1)++instance+ (Rep.Memory l s, LLVM.IsSized s ss) =>+ Rep.Memory (BendModulation l) (LLVM.Struct (s, (s, ()))) where+ load = Rep.loadRecord memory+ store = Rep.storeRecord memory+ decompose = Rep.decomposeRecord memory+ compose = Rep.composeRecord memory+++instance (Loop.Phi a) => Loop.Phi (BendModulation a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable+++instance (Vector.ShuffleMatch n v) =>+ Vector.ShuffleMatch n (BendModulation v) where+ shuffleMatch = Vector.shuffleMatchTraversable++instance (Vector.Access n a v) =>+ Vector.Access n (BendModulation a) (BendModulation v) where+ insert = Vector.insertTraversable+ extract = Vector.extractTraversable
+ src/Synthesizer/LLVM/ALSA/MIDI.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+Convert MIDI events of a MIDI controller to a control signal.+-}+module Synthesizer.LLVM.ALSA.MIDI (+ module Synthesizer.LLVM.ALSA.MIDI,+ Gen.applyModulation,+ PC.BendModulation(PC.BendModulation),+ ) where++import Synthesizer.EventList.ALSA.MIDI+ (Program, Channel, Filter, Note,+ {-+ LazyTime, Controller,+ getControllerEvents, getSlice,+ maybePitchBend, maybeChannelPressure,+ -} )+import qualified Synthesizer.Generic.ALSA.MIDI as Gen+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC+-- import qualified Synthesizer.MIDIValue as MV+import Synthesizer.LLVM.ALSA.BendModulation ()++import Synthesizer.LLVM.CausalParameterized.Process (($>), )+-- import Synthesizer.LLVM.Parameterized.Signal (($#), )+import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Wave as Wave+import qualified Synthesizer.LLVM.Sample as Sample++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Core as LLVM++import qualified Data.TypeLevel.Num as TypeNum++import qualified Synthesizer.Generic.Cut as CutG++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as SVL++{-+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import qualified Data.EventList.Relative.TimeTime as EventListTT+import qualified Data.EventList.Relative.MixedTime as EventListMT+import qualified Data.EventList.Relative.BodyTime as EventListBT+-}++import Foreign.Storable (Storable, )++{-+import qualified Numeric.NonNegative.Class as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky as NonNegChunky+-}++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealField as RealField+-- import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import Control.Arrow (second, (<<<), (<<^), )+import Control.Monad ({- liftM, -} liftM2, )++-- import NumericPrelude.Base+import NumericPrelude.Numeric+import Prelude ()+++{-+{-# INLINE piecewiseConstantInit #-}+piecewiseConstantInit ::+ (Storable y, LLVM.MakeValueTuple y yl,+ Rep.Memory yl ym, LLVM.IsSized ym ys) =>+ y -> EventListTT.T LazyTime y -> SigP.T p yl+piecewiseConstantInit initial evs =+ SigP.piecewiseConstant $#+ (PC.subdivideInt $+ EventListMT.consBody initial evs)+++{-# INLINE controllerLinear #-}+controllerLinear ::+ (Field.C y, Storable y, LLVM.MakeValueTuple y yl,+ Rep.Memory yl ym, LLVM.IsSized ym ys) =>+ Channel -> Controller ->+ (y,y) -> y ->+ Filter (SigP.T p yl)+controllerLinear chan ctrl bnd initial =+ liftM (piecewiseConstantInit initial .+ EventListTT.mapBody (MV.controllerLinear bnd)) $+ getControllerEvents chan ctrl+++{-# INLINE controllerExponential #-}+controllerExponential ::+ (Trans.C y, Storable y, LLVM.MakeValueTuple y yl,+ Rep.Memory yl ym, LLVM.IsSized ym ys) =>+ Channel -> Controller ->+ (y,y) -> y ->+ Filter (SigP.T p yl)+controllerExponential chan ctrl bnd initial =+ liftM (piecewiseConstantInit initial .+ EventListTT.mapBody (MV.controllerExponential bnd)) $+ getControllerEvents chan ctrl+++{- |+@pitchBend channel range center@:+emits frequencies on an exponential scale from+@center/range@ to @center*range@.+-}+{-# INLINE pitchBend #-}+pitchBend ::+ (Trans.C y, Storable y, LLVM.MakeValueTuple y yl,+ Rep.Memory yl ym, LLVM.IsSized ym ys) =>+ Channel ->+ y -> y ->+ Filter (SigP.T p yl)+pitchBend chan range center =+ liftM (piecewiseConstantInit center .+ EventListTT.mapBody (MV.pitchBend range center)) $+ getSlice (maybePitchBend chan)+-- getPitchBendEvents chan++{-# INLINE channelPressure #-}+channelPressure ::+ (Trans.C y, Storable y, LLVM.MakeValueTuple y yl,+ Rep.Memory yl ym, LLVM.IsSized ym ys) =>+ Channel ->+ y -> y ->+ Filter (SigP.T p yl)+channelPressure chan maxVal initVal =+ liftM (piecewiseConstantInit initVal .+ EventListTT.mapBody (MV.controllerLinear (0,maxVal))) $+ getSlice (maybeChannelPressure chan)+++{-# INLINE bendWheelPressure #-}+bendWheelPressure ::+ (Ring.C a, LLVM.IsConst a,+ RealField.C y, Trans.C y,+ LLVM.IsConst y, SoV.Fraction y, SoV.Replicate a y,+ Storable y, LLVM.MakeValueTuple y (LLVM.Value y), LLVM.IsSized y ys) =>+ Channel ->+ Int -> y -> y -> y ->+ Filter (SigP.T p (LLVM.Value y))+bendWheelPressure chan+ pitchRange speed wheelDepth pressDepth =+ do bend <- pitchBend chan+ (2^?(fromIntegral pitchRange/12) `asTypeOf` speed) 1+ fm <- controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0+ press <- channelPressure chan pressDepth 0+ return $+ SigP.envelope bend $+ SigP.mapSimple (A.add (LLVM.valueOf 1)) $+ SigP.envelope+ (SigP.mix fm press)+ (SigP.osciSimple Wave.approxSine2 zero $# speed)+-}+++frequencyFromBendModulation ::+ (Ring.C a, LLVM.IsConst a,+ Ring.C y, Additive.C y, LLVM.IsConst y, LLVM.IsSized y size,+ Storable y, LLVM.MakeValueTuple y (LLVM.Value y),+ SoV.Fraction y, SoV.Replicate a y) =>+ Param.T p y ->+ CausalP.T p (PC.BendModulation (LLVM.Value y)) (LLVM.Value y)+frequencyFromBendModulation speed =+ CausalP.envelope+ <<<+ second+ (CausalP.mapSimple (A.add (SoV.replicateOf 1)) <<< CausalP.envelope+ $> SigP.osciSimple Wave.approxSine2 zero speed)+ <<^+ (\(PC.BendModulation b m) -> (b,m))+++frequencyFromBendModulationPacked ::+ (RealField.C a, LLVM.IsConst a, LLVM.IsFloating a,+ Storable a, LLVM.MakeValueTuple a (LLVM.Value a), LLVM.IsSized a size,+ Vector.Real a, SoV.Replicate a (LLVM.Vector n a), LLVM.IsPowerOf2 n,+ TypeNum.Mul n size vsize, TypeNum.Pos vsize) =>+ Param.T p a ->+ CausalP.T p+ (PC.BendModulation (LLVM.Value a))+ (LLVM.Value (LLVM.Vector n a))+frequencyFromBendModulationPacked speed =+ CausalP.envelope+ <<<+ second+ (CausalP.mapSimple (A.add (SoV.replicateOf 1)) <<< CausalP.envelope+ $> SigPS.osciSimple Wave.approxSine2 zero speed)+ <<<+ CausalP.mapSimple+ (\(PC.BendModulation b m) ->+ liftM2 (,) (SoV.replicate b) (SoV.replicate m))++++type Instrument y yv = Gen.Instrument y (SigSt.T yv)+type Bank y yv = Gen.Bank y (SigSt.T yv)+++{-# INLINE sequenceCore #-}+sequenceCore ::+ (Storable yv, Sample.Additive value,+ LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>+ SigSt.ChunkSize ->+ Channel ->+ Program ->+ Gen.Modulator Note (SigSt.T yv) ->+ Filter (SigSt.T yv)+sequenceCore chunkSize =+ Gen.sequenceCore (SigStL.arrange chunkSize)+++{-# INLINE sequence #-}+sequence ::+ (Storable yv, Trans.C y, Sample.Additive value,+ LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>+ SigSt.ChunkSize ->+ Channel ->+ Instrument y yv ->+ Filter (SigSt.T yv)+sequence chunkSize =+ Gen.sequence (SigStL.arrange chunkSize)+++{-# INLINE sequenceModulated #-}+sequenceModulated ::+ (CutG.Transform ctrl, CutG.NormalForm ctrl,+ Storable yv, Trans.C y, Sample.Additive value,+ LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>+ SigSt.ChunkSize ->+ ctrl ->+ Channel ->+ (ctrl -> Instrument y yv) ->+ Filter (SigSt.T yv)+sequenceModulated chunkSize =+ Gen.sequenceModulated (SigStL.arrange chunkSize)+++{-# INLINE sequenceMultiModulated #-}+sequenceMultiModulated ::+ (Storable yv, Trans.C y, Sample.Additive value,+ LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>+ SigSt.ChunkSize ->+ Channel ->+ instrument ->+ Gen.Modulator (instrument, Note) (Instrument y yv, Note) ->+ Filter (SigSt.T yv)+sequenceMultiModulated chunkSize =+ Gen.sequenceMultiModulated (SigStL.arrange chunkSize)+++{-# INLINE sequenceMultiProgram #-}+sequenceMultiProgram ::+ (Storable yv, Trans.C y, Sample.Additive value,+ LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>+ SigSt.ChunkSize ->+ Channel ->+ Program ->+ [Instrument y yv] ->+ Filter (SigSt.T yv)+sequenceMultiProgram chunkSize =+ Gen.sequenceMultiProgram (SigStL.arrange chunkSize)+++{-# INLINE sequenceModulatedMultiProgram #-}+sequenceModulatedMultiProgram ::+ (CutG.Transform ctrl, CutG.NormalForm ctrl,+ Storable yv, Trans.C y, Sample.Additive value,+ LLVM.MakeValueTuple yv value, Rep.Memory value struct) =>+ SigSt.ChunkSize ->+ ctrl ->+ Channel ->+ Program ->+ [ctrl -> Instrument y yv] ->+ Filter (SigSt.T yv)+sequenceModulatedMultiProgram chunkSize =+ Gen.sequenceModulatedMultiProgram (SigStL.arrange chunkSize)
+ src/Synthesizer/LLVM/Causal/Process.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Synthesizer.LLVM.Causal.Process where++import qualified Synthesizer.LLVM.Simple.Signal as Sig+import qualified LLVM.Extra.Representation as Rep+import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Execution as Exec+import qualified LLVM.Extra.MaybeContinuation as Maybe+-- import qualified LLVM.Extra.Control as U++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import qualified Data.StorableVector.Base as SVB++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import LLVM.Core+import LLVM.Util.Loop (Phi, )+import LLVM.ExecutionEngine (simpleFunction, )++import qualified Control.Arrow as Arr+import qualified Control.Category as Cat+import Control.Arrow ((^<<), (<<<), (<<^), )+import Control.Monad (liftM2, liftM3, )++import Data.Word (Word32, )+import Foreign.Storable (Storable, )+import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, )+import Foreign.Ptr (FunPtr, )+import Control.Exception (bracket, )+import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, )++import Data.Tuple.HT (swap, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (and, map, zip, zipWith, )+++data T a b =+ forall state packed size ioContext.+ (Rep.Memory state packed, IsSized packed size) =>+ Cons (forall r c.+ (Phi c) =>+ ioContext ->+ a -> state -> Maybe.T r c (b, state))+ -- compute next value+ (forall r.+ ioContext ->+ CodeGenFunction r state)+ -- initial state+ (IO ioContext)+ -- initialization from IO monad+ (ioContext -> IO ())+ -- finalization from IO monad++simple ::+ (Rep.Memory state packed, IsSized packed size) =>+ (forall r c.+ (Phi c) =>+ a -> state -> Maybe.T r c (b, state)) ->+ (forall r. CodeGenFunction r state) ->+ T a b+simple next start =+ Cons+ (const next)+ (const start)+ (return ())+ (const $ return ())++toSignal :: T () a -> Sig.T a+toSignal (Cons next start createIOContext deleteIOContext) = Sig.Cons+ (\ioContext -> next ioContext ())+ start+ createIOContext deleteIOContext++fromSignal :: Sig.T a -> T () a+fromSignal (Sig.Cons next start createIOContext deleteIOContext) = Cons+ (\ioContext () -> next ioContext)+ start+ createIOContext deleteIOContext+++map ::+ (forall r. a -> CodeGenFunction r b) ->+ T a b+map f =+ mapAccum (\a s -> fmap (flip (,) s) $ f a) (return ())++mapAccum ::+ (Rep.Memory state packed, IsSized packed size) =>+ (forall r.+ a -> state -> CodeGenFunction r (b, state)) ->+ (forall r. CodeGenFunction r state) ->+ T a b+mapAccum next =+ simple (\a s -> Maybe.lift $ next a s)+++apply ::+ T a b -> Sig.T a -> Sig.T b+apply proc sig =+ toSignal (proc <<< fromSignal sig)++feedFst :: Sig.T a -> T b (a,b)+feedFst sig =+ first (fromSignal sig) <<^ (\b -> ((),b))++feedSnd :: Sig.T a -> T b (b,a)+feedSnd sig =+ swap ^<< feedFst sig+++applyFst :: T (a,b) c -> Sig.T a -> T b c+applyFst proc sig =+ proc <<< feedFst sig++applySnd :: T (a,b) c -> Sig.T b -> T a c+applySnd proc sig =+ proc <<< feedSnd sig++compose :: T a b -> T b c -> T a c+compose+ (Cons nextA startA createIOContextA deleteIOContextA)+ (Cons nextB startB createIOContextB deleteIOContextB) = Cons+ (\(ioContextA, ioContextB) a (sa0,sb0) -> do+ (b,sa1) <- nextA ioContextA a sa0+ (c,sb1) <- nextB ioContextB b sb0+ return (c, (sa1,sb1)))+ (\(ioContextA, ioContextB) ->+ liftM2 (,)+ (startA ioContextA)+ (startB ioContextB))+ (liftM2 (,)+ createIOContextA+ createIOContextB)+ (\(ca,cb) ->+ deleteIOContextA ca >>+ 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+++instance Cat.Category T where+ id = map return+ (.) = flip compose++instance Arr.Arrow T where+ arr f = map (return . f)+ first = first+++mix ::+ (IsArithmetic a) =>+ T (Value a, Value a) (Value a)+mix = map (uncurry Sample.mixMono)++mixStereo ::+ (IsArithmetic a) =>+ T (Stereo.T (Value a), Stereo.T (Value a)) (Stereo.T (Value a))+mixStereo = map (uncurry Sample.mixStereo)+++envelope ::+ (IsArithmetic a) =>+ T (Value a, Value a) (Value a)+envelope = map (uncurry Sample.amplifyMono)++envelopeStereo ::+ (IsArithmetic a) =>+ T (Value a, Stereo.T (Value a)) (Stereo.T (Value a))+envelopeStereo = map (uncurry Sample.amplifyStereo)++amplify ::+ (IsArithmetic a, IsConst a) =>+ a -> T (Value a) (Value a)+amplify x =+ map (Sample.amplifyMono (valueOf x))++amplifyStereo ::+ (IsArithmetic a, IsConst a) =>+ a -> T (Stereo.T (Value a)) (Stereo.T (Value a))+amplifyStereo x =+ map (Sample.amplifyStereo (valueOf x))++++applyStorable ::+ (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,+ Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+ T valueA valueB -> SV.Vector a -> SV.Vector b+applyStorable (Cons next start createIOContext deleteIOContext) as =+ unsafePerformIO $+ bracket createIOContext deleteIOContext $ \ ioContext ->+ SVB.withStartPtr as $ \ aPtr len ->+ SVB.createAndTrim len $ \ bPtr -> do+ fill <-+ simpleFunction $+ createFunction ExternalLinkage $ \ size alPtr blPtr -> do+ s <- start ioContext+ (pos,_) <- Maybe.arrayLoop2 size alPtr blPtr s $+ \ aPtri bPtri s0 -> do+ a <- Maybe.lift $ Rep.load aPtri+ (b,s1) <- next ioContext a s0+ Maybe.lift $ Rep.store b bPtri+ return s1+ ret (pos :: Value Word32)+ fmap (fromIntegral :: Word32 -> Int) $+ fill (fromIntegral len)+ (Rep.castStorablePtr aPtr)+ (Rep.castStorablePtr bPtr)+++foreign import ccall safe "dynamic" derefStartPtr ::+ Exec.Importer (IO (Ptr stateStruct))++foreign import ccall safe "dynamic" derefStopPtr ::+ Exec.Importer (Ptr stateStruct -> IO ())++foreign import ccall safe "dynamic" derefChunkPtr ::+ Exec.Importer (Ptr stateStruct -> Word32 ->+ Ptr aStruct -> Ptr bStruct -> IO Word32)+++compileChunky ::+ (Rep.Memory aValue aStruct,+ Rep.Memory bValue bStruct,+ Rep.Memory state stateStruct,+ IsSized stateStruct stateSize) =>+ (forall r.+ aValue -> state ->+ Maybe.T r (Value Bool, (Value (Ptr bStruct), state)) (bValue, state)) ->+ (forall r.+ CodeGenFunction r state) ->+ IO (FunPtr (IO (Ptr stateStruct)),+ FunPtr (Ptr stateStruct -> IO ()),+ FunPtr (Ptr stateStruct -> Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32))+compileChunky next start =+ Exec.compileModule $+ liftM3 (,,)+ (createFunction ExternalLinkage $+ do+ -- FIXME: size computation in LLVM currently does not work for structs!+ pptr <- Rep.malloc+ flip Rep.store pptr =<< start+ ret pptr)+ (createFunction ExternalLinkage $+ \ pptr -> Rep.free pptr >> ret ())+ (createFunction ExternalLinkage $+ \ sptr loopLen aPtr bPtr -> do+ sInit <- Rep.load sptr+ (pos,sExit) <- Maybe.arrayLoop2 loopLen aPtr bPtr sInit $+ \ aPtri bPtri s0 -> do+ a <- Maybe.lift $ Rep.load aPtri+ (b,s1) <- next a s0+ Maybe.lift $ Rep.store b bPtri+ return s1+ Rep.store sExit sptr+ ret (pos :: Value Word32))+++{-# DEPRECATED runStorableChunky "this function will not work when the process itself depends on a lazy storable vector" #-}+{- |+This function will not work as expected,+since feeding a lazy storable vector to the causal process+means that createIOContext creates a StablePtr to an IORef refering to a chunk list.+The IORef will be created once for all uses of the generated function+of type @(SVL.Vector a -> SVL.Vector b)@.+This means that the pointer into the chunks list will conflict.+An alternative would be to create the StablePtr in a foreign function+that calls back to Haskell.+But this way is disallowed for foreign finalizers.+-}+runStorableChunky ::+ (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,+ Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+ T valueA valueB -> IO (SVL.Vector a -> SVL.Vector b)+runStorableChunky+ (Cons next start createIOContext deleteIOContext) = do+ ioContext <- createIOContext+ (startFunc, stopFunc, fill) <-+ compileChunky (next ioContext) (start ioContext)++ {-+ This is a dummy pointer, that we need for correct finalization.+ Concerning the live time the FunPtr 'fill' also has the live time+ that we are after,+ but it is unsafe to treat a FunPtr as a Ptr or ForeignPtr.+ -}+ ioContextPtr <- Rep.newForeignPtr (deleteIOContext ioContext) False++ return $ \sig -> SVL.fromChunks $ unsafePerformIO $ do+ statePtr <- Rep.newForeignPtrInit stopFunc startFunc+ let go xt =+ unsafeInterleaveIO $+ case xt of+ [] -> return []+ x:xs -> SVB.withStartPtr x $ \aPtr size -> do+ v <-+ withForeignPtr statePtr $ \sptr ->+ SVB.createAndTrim size $+ fmap (fromIntegral :: Word32 -> Int) .+ derefChunkPtr fill sptr (fromIntegral size)+ (Rep.castStorablePtr aPtr) .+ Rep.castStorablePtr+ touchForeignPtr ioContextPtr+ (if SV.length v > 0+ then fmap (v:)+ else id) $+ (if SV.length v < size+ then return []+ else go xs)+ go (SVL.chunks sig)+++applyStorableChunky ::+ (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,+ Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+ T valueA valueB -> SVL.Vector a -> SVL.Vector b+applyStorableChunky+ (Cons next start createIOContext deleteIOContext) sig =+ SVL.fromChunks $ unsafePerformIO $ do+ ioContext <- createIOContext+ (startFunc, stopFunc, fill) <-+ compileChunky (next ioContext) (start ioContext)++ statePtr <- Rep.newForeignPtrInit stopFunc startFunc+ {-+ This is a dummy pointer, that we need for correct finalization.+ Concerning the live time the FunPtr 'fill' also has the live time+ that we are after,+ but it is unsafe to treat a FunPtr as a Ptr or ForeignPtr.+ -}+ ioContextPtr <- Rep.newForeignPtr (deleteIOContext ioContext) False++ let go xt =+ unsafeInterleaveIO $+ case xt of+ [] -> return []+ x:xs -> SVB.withStartPtr x $ \aPtr size -> do+ v <-+ withForeignPtr statePtr $ \sptr ->+ SVB.createAndTrim size $+ fmap (fromIntegral :: Word32 -> Int) .+ derefChunkPtr fill sptr (fromIntegral size)+ (Rep.castStorablePtr aPtr) .+ Rep.castStorablePtr+ touchForeignPtr ioContextPtr+ (if SV.length v > 0+ then fmap (v:)+ else id) $+ (if SV.length v < size+ then return []+ else go xs)+ go (SVL.chunks sig)
+ src/Synthesizer/LLVM/CausalParameterized/Controlled.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+This module provides a type class that automatically selects a filter+for a given parameter type.+We choose the dependency this way+because there may be different ways to specify the filter parameters+but there is only one implementation of the filter itself.+-}+module Synthesizer.LLVM.CausalParameterized.Controlled where++import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as ComplexFiltPack+import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilt+import qualified Synthesizer.LLVM.Filter.Allpass as Allpass+import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1+import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2+import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade+import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P+import qualified Synthesizer.LLVM.Filter.Moog as Moog+import qualified Synthesizer.LLVM.Filter.Universal as UniFilter++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Vector as Vector+import qualified Synthesizer.LLVM.Parameter as Param++import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, Vector, IsArithmetic, IsFloating, IsConst, IsSized, IsFirstClass, )++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified Data.TypeLevel.Num as TypeNum+import qualified Data.TypeLevel.Num.Sets as TypeSet++import Foreign.Storable (Storable, )++import qualified Algebra.Field as Field+import qualified Algebra.Module as Module+import qualified Algebra.Ring as Ring+++{- |+A filter parameter type uniquely selects a filter function.+However it does not uniquely determine the input and output type,+since the same filter can run on mono and stereo signals.+-}+class C parameter a b | parameter a -> b, parameter b -> a where+ process :: CausalP.T p (parameter, a) b+++processCtrlRate ::+ (C parameter a b,+ Rep.Memory parameter struct,+ IsSized struct ss,+ Ring.C r, IsFloating r, Storable r, IsConst r,+ LLVM.MakeValueTuple r (Value r),+ LLVM.CmpRet r Bool,+ IsSized r rs) =>+ Param.T p r ->+ (Param.T p r -> SigP.T p parameter) ->+ CausalP.T p a b+processCtrlRate reduct ctrlGen =+ CausalP.applyFst process+ (SigP.interpolateConstant reduct (ctrlGen reduct))+++{-+Instances for the particular filters shall are defined here+in order to avoid orphan instances.+-}++instance+ (Ring.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,+ IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) =>+ C (Filt1.Parameter (Value a))+ (Value v) (Filt1.Result (Value v)) where+ process = Filt1.causalP++instance+ (Ring.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,+ IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) =>+ C (Filt2.Parameter (Value a))+ (Value v) (Value v) where+ process = Filt2.causalP++instance+ (Field.C a, IsConst a, Vector.Arithmetic a,+ IsSized (Vector TypeNum.D4 a) as) =>+ C (Filt2P.Parameter a)+ (Value a) (Value a) where+ process = Filt2P.causalP++instance+ (Ring.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,+ IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v,+ TypeSet.Nat n,+ TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) =>+ C (Cascade.ParameterValue n a)+ (Value v) (Value v) where+ process = Cascade.causalP+++instance+ (Field.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,+ IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) =>+ C (Allpass.Parameter (Value a))+ (Value v) (Value v) where+ process = Allpass.causalP++instance+ (Field.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,+ IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v,+ TypeNum.Nat n) =>+ C (Allpass.CascadeParameter n (Value a))+ (Value v) (Value v) where+ process = Allpass.cascadeP+++instance+ (Module.C a v, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,+ IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v,+ LLVM.MakeValueTuple a (Value a),+ LLVM.MakeValueTuple v (Value v),+ Storable v,+ TypeSet.Nat n) =>+ C (Moog.Parameter n (Value a))+ (Value v) (Value v) where+ process = Moog.causalP+++instance+ (Field.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,+ IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) =>+ C (UniFilter.Parameter (Value a))+ (Value v) (UniFilter.Result (Value v)) where+ process = UniFilter.causalP++instance+ (IsFirstClass a, IsSized a sa, IsConst a, IsFloating a) =>+ C (ComplexFilt.Parameter (Value a))+ (Stereo.T (Value a)) (Stereo.T (Value a)) where+ process = ComplexFilt.causalP++instance+ (IsConst a, Vector.Arithmetic a,+ IsSized (Vector TypeNum.D4 a) as) =>+ C (ComplexFiltPack.Parameter a)+ (Stereo.T (Value a)) (Stereo.T (Value a)) where+ process = ComplexFiltPack.causalP
+ src/Synthesizer/LLVM/CausalParameterized/ControlledPacked.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+This is like "Synthesizer.LLVM.CausalParameterized.Controlled"+but for vectorised signals.+-}+module Synthesizer.LLVM.CausalParameterized.ControlledPacked (+ C(process), processCtrlRate,+ ) where++import qualified Synthesizer.LLVM.Filter.Allpass as Allpass+import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1+import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2+import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade+import qualified Synthesizer.LLVM.Filter.Moog as Moog+import qualified Synthesizer.LLVM.Filter.Universal as UniFilter++import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Vector as Vector+import qualified Synthesizer.LLVM.Parameter as Param++import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, Vector, IsArithmetic, IsFloating, IsConst, IsSized,+ IsFirstClass, IsPrimitive, IsPowerOf2, )++import qualified Data.TypeLevel.Num as TypeNum+import qualified Data.TypeLevel.Num.Sets as TypeSet++import Foreign.Storable (Storable, )++import Control.Arrow ((<<<), first, )++import qualified Algebra.Field as Field+import qualified Algebra.Module as Module+import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- |+A filter parameter type uniquely selects a filter function.+However it does not uniquely determine the input and output type,+since the same filter can run on mono and stereo signals.+-}+class C parameter a b | parameter a -> b, parameter b -> a where+ process :: CausalP.T p (parameter, a) b++processCtrlRate ::+ (C parameter av bv,+ Vector.Access n a av,+ Vector.Access n b bv,+ Rep.Memory parameter struct, IsSized struct ss,+ Field.C r, IsFloating r, Storable r, IsConst r,+ LLVM.MakeValueTuple r (Value r),+ LLVM.CmpRet r Bool,+ IsSized r rs) =>+ Param.T p r ->+ (Param.T p r -> SigP.T p parameter) ->+ CausalP.T p av bv+processCtrlRate reduct ctrlGen = withSize $ \n ->+ CausalP.applyFst process+ (SigP.interpolateConstant+ (fmap (/ fromIntegral (TypeNum.toInt n)) reduct)+ (ctrlGen reduct))++withSize ::+ (Vector.Access n a av,+ Vector.Access n b bv) =>+ (n -> CausalP.T p av bv) ->+ CausalP.T p av bv+withSize f = f undefined+++{-+Instances for the particular filters shall be defined here+in order to avoid orphan instances.+-}++instance+ (Ring.C a, IsArithmetic a, IsPrimitive a,+ IsFirstClass a, IsConst a, IsSized a as,+ IsPowerOf2 n) =>+ C (Filt1.Parameter (Value a))+ (Value (Vector n a)) (Filt1.Result (Value (Vector n a))) where+ process = Filt1.causalPackedP++instance+ (Ring.C a, IsFirstClass a, IsArithmetic a, IsConst a,+ IsPowerOf2 n, IsPrimitive a, IsSized a as,+ TypeNum.Mul n as vas, TypeNum.Pos vas) =>+ C (Filt2.Parameter (Value a))+ (Value (Vector n a)) (Value (Vector n a)) where+ process = Filt2.causalPackedP++instance+ (Ring.C a, IsPrimitive a, IsSized a as, IsConst a,+ IsArithmetic a, TypeSet.Nat n,+ TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize,+ IsPowerOf2 d, TypeNum.Mul d as vas, TypeSet.Pos vas) =>+ C (Cascade.ParameterValue n a)+ (Value (Vector d a)) (Value (Vector d a)) where+ process = Cascade.causalPackedP+++instance+ (Ring.C a, IsFirstClass a, IsArithmetic a, IsConst a,+ IsPowerOf2 n, IsPrimitive a, IsSized a as) =>+ C (Allpass.Parameter (Value a))+ (Value (Vector n a)) (Value (Vector n a)) where+ process = Allpass.causalPackedP++instance+ (Field.C a, IsFirstClass a, IsArithmetic a, IsConst a,+ IsPowerOf2 d, IsPrimitive a, IsSized a as,+ TypeNum.Nat n) =>+ C (Allpass.CascadeParameter n (Value a))+ (Value (Vector d a)) (Value (Vector d a)) where+ process = Allpass.cascadePackedP+++instance+ (Module.C a a, IsFirstClass a, IsArithmetic a, IsConst a,+ LLVM.MakeValueTuple a (Value a), Storable a,+ IsPowerOf2 d, IsPrimitive a, IsSized a as,+ TypeNum.Nat n) =>+ C (Moog.Parameter n (Value a))+ (Value (Vector d a)) (Value (Vector d a)) where+ process =+ CausalPS.pack Moog.causalP <<<+ first (CausalP.mapSimple Vector.replicate)+++instance+ (Field.C a, IsFirstClass a, IsArithmetic a, IsConst a,+ IsPowerOf2 d, IsPrimitive a, IsSized a as) =>+ C (UniFilter.Parameter (Value a))+ (Value (Vector d a)) (UniFilter.Result (Value (Vector d a))) where+ process =+ CausalPS.pack UniFilter.causalP <<<+ first (CausalP.mapSimple Vector.replicate)
+ src/Synthesizer/LLVM/CausalParameterized/Process.hs view
@@ -0,0 +1,860 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Synthesizer.LLVM.CausalParameterized.Process (+ T(Cons), simple,+ mapAccum, map, mapSimple,+ apply, compose, first,+ feedFst, feedSnd,+ take, integrate,+ module Synthesizer.LLVM.CausalParameterized.Process+ ) where++import Synthesizer.LLVM.CausalParameterized.ProcessPrivate+import qualified Synthesizer.LLVM.Parameter as Param++import Synthesizer.LLVM.Parameterized.Signal (($#), )+import qualified Synthesizer.LLVM.Parameterized.Signal as Sig+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Execution as Exec+import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import qualified Data.StorableVector.Base as SVB++import qualified Synthesizer.Plain.Modifier as Modifier++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.Representation as Rep+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Arithmetic as A++import LLVM.Core as LLVM+import Data.TypeLevel.Num (D2, )+import qualified Data.TypeLevel.Num as TypeNum+import qualified Data.TypeLevel.Num.Sets as Sets++import qualified Control.Monad.HT as M+import qualified Control.Arrow as Arr+import qualified Control.Category as Cat+import Control.Monad.Trans.State (runState, state, evalState, )+import Control.Arrow ((<<<), (>>>), (&&&), )+import Control.Monad (liftM2, liftM3, )+import Control.Applicative (liftA2, )++import System.Random (Random, RandomGen, randomR, )++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import Data.Function.HT (nest, )+import Data.Word (Word32, )+import Foreign.Storable.Tuple ()+import Foreign.Storable (Storable, poke, )+import qualified Foreign.Marshal.Array as Array+import qualified Foreign.Marshal.Alloc as Alloc+import Foreign.ForeignPtr (withForeignPtr, )+import Foreign.Ptr (FunPtr, )+import Control.Exception (bracket, )+import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, )++import qualified Data.List as List++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, )+++infixl 0 $<, $>, $*, $<#, $>#, $*#+-- infixr 0 $:* -- can be used together with $++applyFst, ($<) :: T p (a,b) c -> Sig.T p a -> T p b c+applyFst proc sig =+ proc <<< feedFst sig++applySnd, ($>) :: T p (a,b) c -> Sig.T p b -> T p a c+applySnd proc sig =+ proc <<< feedSnd sig++{-+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+($*) = apply+($<) = applyFst+($>) = applySnd++{- |+provide constant input in a comfortable way+-}+($*#) ::+ (Storable ah, MakeValueTuple ah a,+ Rep.Memory a am, IsSized am as) =>+ T p a b -> ah -> Sig.T p b+proc $*# x = proc $* (Sig.constant $# x)++($<#) ::+ (Storable ah, MakeValueTuple ah a,+ Rep.Memory a am, IsSized am as) =>+ T p (a,b) c -> ah -> T p b c+proc $<# x = proc $< (Sig.constant $# x)++($>#) ::+ (Storable bh, MakeValueTuple bh b,+ Rep.Memory b bm, IsSized bm bs) =>+ T p (a,b) c -> bh -> T p a c+proc $># x = proc $> (Sig.constant $# x)+++mapAccumSimple ::+ (Rep.Memory s struct, IsSized struct sa) =>+ (forall r. a -> s -> CodeGenFunction r (b,s)) ->+ (forall r. CodeGenFunction r s) ->+ T p a b+mapAccumSimple f s =+ mapAccum (\() -> f) (\() -> s) (return ()) (return ())++{- |+Not quite the loop of ArrowLoop+because we need a delay of one time step+and thus an initialization value.++For a real ArrowLoop.loop, that is a zero-delay loop,+we would formally need a MonadFix instance of CodeGenFunction.+But this will not become reality, since LLVM is not able to re-order code+in a way that allows to access a result before creating the input.+-}+loop ::+ (Storable ch,+ MakeValueTuple ch c,+ Rep.Memory c cp,+ IsSized cp cs) =>+ Param.T p ch -> T p (a,c) (b,c) -> T p a b+loop initial (Cons next start createIOContext deleteIOContext) =+ Cons+ (\p a0 (c0,s0) -> do+ ((b1,c1), s1) <- next p (a0,c0) s0+ return (b1,(c1,s1)))+ (\(i,p) -> fmap ((,) (Param.value initial i)) $ start p)+ (\p -> do+ (ctx,(nextParam,startParam)) <- createIOContext p+ return (ctx,+ (nextParam, (Param.get initial p, startParam))))+ deleteIOContext+++-- cf. synthesizer-core:Causal.Process, can be defined for any arrow+{-# INLINE replicateControlled #-}+replicateControlled :: Int -> T p (c,x) x -> T p (c,x) x+replicateControlled n p =+ nest n+ (Arr.arr fst &&& p >>> )+ (Arr.arr snd)++-- cf. synthesizer-core:Causal.Process+{-# INLINE feedbackControlled #-}+feedbackControlled ::+ (Storable ch,+ MakeValueTuple ch c,+ Rep.Memory c cp,+ IsSized cp cs) =>+ Param.T p ch ->+ T p ((ctrl,a),c) b -> T p (ctrl,b) c -> T p (ctrl,a) b+feedbackControlled initial forth back =+ loop initial+ (Arr.arr (fst.fst) &&& forth >>> Arr.arr snd &&& back)+++fromModifier ::+ (Value.Flatten ah al, Value.Flatten bh bl, Value.Flatten ch cl,+ Value.Flatten sh sl, Rep.Memory sl sp, IsSized sp ss) =>+ Modifier.Simple sh ch ah bh -> T p (cl,al) bl+fromModifier (Modifier.Simple initial step) =+ mapAccumSimple+ (\(c,a) s ->+ Value.flatten $+ runState+ (step (Value.unfold c) (Value.unfold a))+ (Value.unfold s))+ (Value.flatten initial)+++{- |+Run a causal process independently on each stereo channel.+-}+stereoFromMono ::+ T p a b -> T p (Stereo.T a) (Stereo.T b)+stereoFromMono =+ Stereo.arrowFromMono++stereoFromMonoControlled ::+ T p (c,a) b -> T p (c, Stereo.T a) (Stereo.T b)+stereoFromMonoControlled =+ Stereo.arrowFromMonoControlled++stereoFromChannels ::+ T p a b -> T p a b -> T p (Stereo.T a) (Stereo.T b)+stereoFromChannels =+ Stereo.arrowFromChannels++{-+In order to let this work we have to give the disable-mmx option somewhere,+but where?+-}+stereoFromVector ::+ (IsPrimitive a, IsPrimitive b) =>+ T p (Value (Vector D2 a)) (Value (Vector D2 b)) ->+ T p (Stereo.T (Value a)) (Stereo.T (Value b))+stereoFromVector proc =+ mapSimple Sample.stereoFromVector <<<+ proc <<<+ mapSimple Sample.vectorFromStereo+++vectorize ::+ (Vector.Access n a va, Vector.Access n b vb) =>+ T p a b -> T p va vb+vectorize = vectorizeSize undefined++{-+insert and extract instructions will be in opposite order,+no matter whether we use foldr or foldl+and independent from the order of proc and channel in replaceChannel.+However, LLVM neglects the order anyway.+-}+vectorizeSize ::+ (Vector.Access n a va, Vector.Access n b vb) =>+ n -> T p a b -> T p va vb+vectorizeSize n proc =+ foldl+ (\acc i -> replaceChannel i proc acc)+ (Arr.arr (const $ LLVM.undefTuple)) $+ List.take (TypeNum.toInt n) [0 ..]++{- |+Given a vector process, replace the i-th output by output+that is generated by a scalar process from the i-th input.+-}+replaceChannel ::+ (Vector.Access n a va, Vector.Access n b vb) =>+ Int -> T p a b -> T p va vb -> T p va vb+replaceChannel i channel proc =+ let li = valueOf $ fromIntegral i+ in mapSimple (uncurry (Vector.insert li)) <<<+ (channel <<< mapSimple (Vector.extract li)) &&&+ proc+++zipWithSimple ::+ (forall r. a -> b -> CodeGenFunction r c) ->+ T p (a,b) c+zipWithSimple f =+ mapSimple (uncurry f)++mix ::+ (IsArithmetic a) =>+ T p (Value a, Value a) (Value a)+mix =+ zipWithSimple Sample.mixMono++mixStereo ::+ (IsArithmetic a) =>+ T p (Stereo.T (Value a), Stereo.T (Value a)) (Stereo.T (Value a))+mixStereo =+ zipWithSimple Sample.mixStereo+++raise ::+ (IsArithmetic a, Storable a,+ MakeValueTuple a (Value a), IsSized a size) =>+ Param.T p a -> T p (Value a) (Value a)+raise =+ map Sample.mixMono+++envelope ::+ (IsArithmetic a) =>+ T p (Value a, Value a) (Value a)+envelope =+ zipWithSimple Sample.amplifyMono++envelopeStereo ::+ (IsArithmetic a) =>+ T p (Value a, Stereo.T (Value a)) (Stereo.T (Value a))+envelopeStereo =+ zipWithSimple Sample.amplifyStereo++amplify ::+ (IsArithmetic a, Storable a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+ Param.T p a -> T p (Value a) (Value a)+amplify =+ map Sample.amplifyMono++amplifyStereo ::+ (IsArithmetic a, Storable a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+ Param.T p a -> T p (Stereo.T (Value a)) (Stereo.T (Value a))+amplifyStereo =+ map Sample.amplifyStereo++++mapLinear ::+ (IsArithmetic a, Storable a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+ Param.T p a -> Param.T p a -> T p (Value a) (Value a)+mapLinear depth center =+ map+ (\(d,c) x -> A.add c =<< A.mul d x)+ (depth&&¢er)++mapExponential ::+ (Trans.C a, IsFloating a, IsConst a, Storable a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+ Param.T p a -> Param.T p a -> T p (Value a) (Value a)+mapExponential depth center =+ map+ (\(d,c) x ->+ A.mul c =<< A.exp =<< A.mul d x)+ (log depth &&& center)+++{- |+@quantizeLift k f@ applies the process @f@ to every @k@th sample+and repeats the result @k@ times.++Like 'SigP.interpolateConstant' this function can be used+for computation of filter parameters at a lower rate.+This can be useful, if you have a frequency control signal at sample rate+that shall be used both for an oscillator and a frequency filter.+-}+quantizeLift ::+ (Rep.Memory b struct, IsSized struct size,+ Ring.C c,+ IsFloating c, CmpRet c Bool,+ Storable c, MakeValueTuple c (Value c),+ IsConst c, IsFirstClass c, IsSized c sc) =>+ Param.T p c ->+ T p a b ->+ T p a b+quantizeLift k+ (Cons next start createIOContext deleteIOContext) = Cons+ (\(kl,parameter) a0 bState0 -> do+ ((b1,state1), ss1) <-+ Maybe.fromBool $+ C.whileLoop+ (valueOf True, bState0)+ (\(cont1, (_, ss1)) ->+ and cont1 =<< A.fcmp FPOLE ss1 (value LLVM.zero))+ (\(_,((_,state01), ss1)) ->+ Maybe.toBool $ liftM2 (,)+ (next parameter a0 state01)+ (Maybe.lift $ A.add ss1 (Param.value k kl)))++ ss2 <- Maybe.lift $ A.sub ss1 (valueOf Ring.one)+ return (b1, ((b1,state1),ss2)))+ (fmap (\sa -> ((undefTuple, sa), value LLVM.zero)) . start)+ (\p -> do+ (ioContext, (nextParam, startParam)) <- createIOContext p+ return (ioContext, ((Param.get k p, nextParam), startParam)))+ deleteIOContext+++{- |+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 ::+ (IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t,+ Additive.C t) =>+ T p (Value t, Value t) (Value t)+osciCore =+ mapSimple (uncurry SoV.addToPhase) <<<+ Arr.second+ (mapAccumSimple+ (\a s -> do+ b <- SoV.incPhase a s+ return (s,b))+ (return (valueOf Additive.zero)))++osciSimple ::+ (IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t,+ Additive.C t) =>+ (forall r. Value t -> CodeGenFunction r y) ->+ T p (Value t, Value t) y+osciSimple wave =+ mapSimple wave <<< osciCore++shapeModOsci ::+ (IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t,+ Additive.C t) =>+ (forall r. c -> Value t -> CodeGenFunction r y) ->+ T p (c, (Value t, Value t)) y+shapeModOsci wave =+ mapSimple (uncurry wave) <<< Arr.second osciCore++++{- |+Delay time must be non-negative.++The initial value is needed in order to determine the ring buffer element type.+-}+delay ::+ (Storable a,+ MakeValueTuple a al,+ Rep.Memory al ap,+ IsSized ap as) =>+ Param.T p a -> Param.T p Int -> T p al al+delay initial time =+ let time32 = fmap (fromIntegral :: Int -> Word32) time in+ Cons+ (\(size,ptr) a0 (remain0,ptri0) -> Maybe.lift $ do+ Rep.store a0 ptri0+ cont <- A.icmp IntNE remain0 (valueOf 0)+ (remain1,ptri1) <-+ C.ifThenSelect cont (Param.value time32 size, ptr)+ (liftM2 (,)+ (A.dec remain0)+ (A.advanceArrayElementPtr ptri0))+ a1 <- Rep.load ptri1+ return (a1, (remain1,ptri1)))+ (\(x, (size,ptr)) -> do+ size1 <- A.inc (Param.value time32 size)+ -- cf. LLVM.Storable.Signal.fill+ C.arrayLoop size1 ptr () $ \ ptri () ->+ Rep.store (Param.value initial x) ptri >> return ()+ return (size,ptr))+ (\p -> do+ let size = Param.get time p+ x = Param.get initial p+ {-+ We allocate one element more than necessary+ in order to simplify handling of delay time zero+ -}+ ptr <- Array.mallocArray (size+1)+ let param =+ (fromIntegral size :: Word32,+ Rep.castStorablePtr (ptrAsTypeOf ptr x))+ return (ptr, (param, (x, param))))+ Alloc.free++ptrAsTypeOf :: Ptr a -> a -> Ptr a+ptrAsTypeOf p _ = p++{- |+Delay by one sample.+For very small delay times (say up to 8)+it may be more efficient to apply 'delay1' several times+or to use a pipeline,+e.g. @pipeline (id :: T (Vector D4 Float) (Vector D4 Float))@+delays by 4 samples in an efficient way.+In principle it would be also possible to use+@unpack (delay1 (const $ toVector (0,0,0,0)))@+but 'unpack' causes an additional delay.+Thus @unpack (id :: T (Vector D4 Float) (Vector D4 Float))@ may do,+what you want.+-}+delay1 ::+ (Storable a,+ MakeValueTuple a al,+ Rep.Memory al ap,+ IsSized ap as) =>+ Param.T p a -> T p al al+delay1 initial = simple+ (\() a s -> return (s,a))+ return+ (return ())+ initial+++{- |+Delay time must be greater than zero!+-}+comb ::+ (Ring.C a,+ Storable a,+ IsArithmetic a,+ MakeValueTuple a (Value a),+ IsFirstClass a,+ IsSized a as) =>+ Param.T p a -> Param.T p Int ->+ T p (Value a) (Value a)+comb gain time =+ let z = Additive.zero `asTypeOf` gain+ in loop z (mix >>> (Cat.id &&&+ (delay z (subtract 1 time) >>> amplify gain)))++combStereo ::+ (Ring.C a,+ Storable a,+ IsArithmetic a,+ MakeValueTuple a (Value a),+ IsFirstClass a,+ IsSized a as) =>+ Param.T p a -> Param.T p Int ->+ T p (Stereo.T (Value a)) (Stereo.T (Value a))+combStereo gain time =+ let z = Additive.zero `asTypeOf` (liftA2 Stereo.cons gain gain)+ in loop z (mixStereo >>> (Cat.id &&&+ (delay z (subtract 1 time) >>> amplifyStereo gain)))++reverb ::+ (Field.C a, Random a,+ Storable a, IsArithmetic a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a as,+ RandomGen g) =>+ g -> Int -> (a,a) -> (Int,Int) ->+ T p (Value a) (Value a)+reverb rnd num gainRange timeRange =+ amplify (return (recip (fromIntegral num))) <<<+ (foldl (\proc chan -> mix <<< (proc &&& chan)) Cat.id $+ List.take num $+ List.map (\(g,t) -> comb $# g $# t) $+ flip evalState rnd $+ M.repeat $+ liftM2 (,)+ (state (randomR gainRange))+ (state (randomR timeRange)))+++{- |+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.Access n a v, Class.Zero v,+ Rep.Memory v vp, IsSized vp s) =>+ T p v v -> T p a a+pipeline (Cons next start createIOContext deleteIOContext) = Cons+ (\param a0 (v0,s0) -> do+ (a1,v1) <- Maybe.lift $ Vector.shiftUp a0 v0+ (v2,s2) <- next param v1 s0+ return (a1, (v2,s2)))+ (\p -> do+ s <- start p+ return (Class.zeroTuple, s))+ createIOContext+ deleteIOContext+++linearInterpolation ::+ (Ring.C a, IsArithmetic a, IsConst a) =>+ Value a -> (Value a, Value a) -> CodeGenFunction r (Value a)+linearInterpolation r (a,b) = do+ ra <- A.mul a =<< A.sub (valueOf one) r+ rb <- A.mul b r+ A.add ra rb+++{- |+> frequencyModulationLinear signal++is a causal process mapping from a shrinking factor+to the modulated input @signal@.+Similar to 'Sig.interpolateConstant'+but the factor is reciprocal and controllable+and we use linear interpolation.+The shrinking factor must be non-negative.+-}+frequencyModulationLinear ::+ (-- Rep.Memory a struct, IsSized struct size,+ Ring.C a,+ IsFloating a, CmpRet a Bool,+ Storable a, MakeValueTuple a (Value a),+ IsConst a, IsFirstClass a, IsSized a sa) =>+ Sig.T p (Value a) -> T p (Value a) (Value a)+frequencyModulationLinear+ (Sig.Cons next start createIOContext deleteIOContext) =+ Cons+ (\parameter k yState0 -> do+ (((y02,y12),state2), ss2) <-+ Maybe.fromBool $+ C.whileLoop+ (valueOf True, yState0)+ (\(cont0, (_, ss0)) ->+ and cont0 =<< A.fcmp FPOGE ss0 (valueOf Ring.one))+ (\(_,(((_,y01),state0), ss0)) ->+ Maybe.toBool $ liftM2 (,)+ (do (y11,state1) <- next parameter state0+ return ((y01,y11),state1))+ (Maybe.lift $ A.sub ss0 (valueOf Ring.one)))++ Maybe.lift $ do+ y <- linearInterpolation ss2 (y02,y12)+ ss3 <- A.add ss2 k+ return (y, (((y02,y12),state2),ss3)))+ (\p -> do+ sa <- start p+ return (((value undef, value undef), sa), valueOf 2))+ createIOContext+ deleteIOContext+++{- |+@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.++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.+-}+trigger ::+ (Storable a, MakeValueTuple a al, C.Select al,+ Rep.Memory al as, IsSized as asize) =>+ Param.T p a ->+ Sig.T p al ->+ T p (Value Bool) al+trigger fill (Sig.Cons next start createIOContext deleteIOContext) = Cons+ (\(nextParam, startParam, f) b0 (active0, s0) -> Maybe.lift $ do+ (active1,s1) <-+ C.ifThen b0 (active0,s0)+ (fmap ((,) (valueOf False)) $ start startParam)+ (active2,(a2,s2)) <-+ Maybe.toBool $ Maybe.guard active1 >> next nextParam s1+ a3 <- C.select active2 a2 (Param.value fill f)+ return (a3,(active2,s2)))+ (\() -> return (valueOf False, undefTuple))+ (\p -> do+ (context, (nextParam, startParam)) <- createIOContext p+ return (context, ((nextParam, startParam, Param.get fill p), ())))+ deleteIOContext+++{- |+On each restart the parameters of type @b@ are passed to the signal.++triggerParam ::+ (MakeValueTuple a al,+ MakeValueTuple b bl) =>+ Param.T p a ->+ (Param.T p b -> Sig.T p a) ->+ T p (Value Bool, bl) al+triggerParam fill sig =+-}++++foreign import ccall safe "dynamic" derefFillPtr ::+ Exec.Importer (Ptr param -> Word32 -> Ptr a -> Ptr b -> IO Word32)++runStorable ::+ (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,+ Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+ T p valueA valueB ->+ IO (p -> SV.Vector a -> SV.Vector b)+runStorable (Cons next start createIOContext deleteIOContext) = do+ fill <-+ fmap derefFillPtr $+ Exec.compileModule $+ createFunction ExternalLinkage $+ \paramPtr size alPtr blPtr -> do+ (nextParam,startParam) <- Rep.load paramPtr+ s <- start startParam+ (pos,_) <- Maybe.arrayLoop2 size alPtr blPtr s $+ \ aPtri bPtri s0 -> do+ a <- Maybe.lift $ Rep.load aPtri+ (b,s1) <- next nextParam a s0+ Maybe.lift $ Rep.store b bPtri+ return s1+ ret (pos :: Value Word32)++ return $ \p as ->+ unsafePerformIO $+ bracket (createIOContext p) (deleteIOContext . fst) $+ \ (_,params) ->+ SVB.withStartPtr as $ \ aPtr len ->+ SVB.createAndTrim len $ \ bPtr ->+ Alloc.alloca $ \paramPtr ->+ poke paramPtr params >>+ (fmap fromIntegral $+ fill (Rep.castStorablePtr paramPtr)+ (fromIntegral len)+ (Rep.castStorablePtr aPtr)+ (Rep.castStorablePtr bPtr))++applyStorable ::+ (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,+ Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+ T p valueA valueB ->+ p -> SV.Vector a -> SV.Vector b+applyStorable gen = unsafePerformIO $ runStorable gen++++foreign import ccall safe "dynamic" derefChunkPtr ::+ Exec.Importer (Ptr nextParamStruct -> Ptr stateStruct -> Word32 ->+ Ptr structA -> Ptr structB -> IO Word32)+++compileChunky ::+ (Rep.Memory valueA structA,+ Rep.Memory valueB structB,+ Rep.Memory state stateStruct,+ IsSized stateStruct stateSize,+ Rep.Memory startParamValue startParamStruct,+ Rep.Memory nextParamValue nextParamStruct,+ IsSized startParamStruct startParamSize,+ IsSized nextParamStruct nextParamSize) =>+ (forall r.+ nextParamValue ->+ valueA -> state ->+ Maybe.T r (Value Bool, (Value (Ptr structB), state)) (valueB, state)) ->+ (forall r.+ startParamValue ->+ CodeGenFunction r state) ->+ IO (FunPtr (Ptr startParamStruct -> IO (Ptr stateStruct)),+ FunPtr (Ptr stateStruct -> IO ()),+ FunPtr (Ptr nextParamStruct -> Ptr stateStruct -> Word32 ->+ Ptr structA -> Ptr structB -> IO Word32))+compileChunky next start =+ Exec.compileModule $+ liftM3 (,,)+ (createFunction ExternalLinkage $+ \paramPtr -> do+ -- FIXME: size computation in LLVM currently does not work for structs!+ pptr <- Rep.malloc+ flip Rep.store pptr =<< start =<< Rep.load paramPtr+ ret pptr)+ (createFunction ExternalLinkage $+ \ pptr -> Rep.free pptr >> ret ())+ (createFunction ExternalLinkage $+ \ paramPtr sptr loopLen aPtr bPtr -> do+ param <- Rep.load paramPtr+ sInit <- Rep.load sptr+ (pos,sExit) <- Maybe.arrayLoop2 loopLen aPtr bPtr sInit $+ \ aPtri bPtri s0 -> do+ a <- Maybe.lift $ Rep.load aPtri+ (b,s1) <- next param a s0+ Maybe.lift $ Rep.store b bPtri+ return s1+ Rep.store sExit sptr+ ret (pos :: Value Word32))+++runStorableChunky ::+ (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,+ Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+ T p valueA valueB ->+ IO (p -> SVL.Vector a -> SVL.Vector b)+runStorableChunky proc =+ fmap ($ const SVL.empty) $+ runStorableChunkyCont proc++{-+I liked to write something with signature++> import qualified Synthesizer.Causal.Process as Causal+>+> liftStorableChunk ::+> T p valueA valueB ->+> IO (p -> Causal.T (SV.Vector a) (SV.Vector b))++This could be used to convert a LLVM causal process+to something that works on Haskell values (here: strict storable vectors).+In a second step we could convert this to a processor of lazy lists,+and thus to a processor of chunky storable vectors.+Unfortunately @Causal.T@ uses an immutable state internally,+whereas @T@ uses mutable states.+In principle the immutable state of @Causal.T@+could be used for breaking the processing of a stream+and continue it on two different streams in parallel.+I have no function that makes use of this feature,+and thus an @ST@ monad might be a way out.+-}++{- |+This function should be used+instead of @StorableVector.Lazy.Pattern.splitAt@ and subsequent @append@,+because it does not have the risk of a memory leak.+-}+runStorableChunkyCont ::+ (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,+ Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+ T p valueA valueB ->+ IO ((SVL.Vector a -> SVL.Vector b) ->+ p ->+ SVL.Vector a -> SVL.Vector b)+runStorableChunkyCont (Cons next start createIOContext deleteIOContext) = do+ (startFunc, stopFunc, fill) <- compileChunky next start+ return $+ \ procRest p sig ->+ SVL.fromChunks $ unsafePerformIO $ do+ (ioContext, (nextParam, startParam)) <- createIOContext p++ statePtr <- Rep.newForeignPtrParam stopFunc startFunc startParam+ nextParamPtr <-+ Rep.newForeignPtr (deleteIOContext ioContext) nextParam++ let go xt =+ unsafeInterleaveIO $+ case xt of+ [] -> return []+ x:xs -> SVB.withStartPtr x $ \aPtr size -> do+ v <-+ Rep.withForeignPtr nextParamPtr $ \nptr ->+ withForeignPtr statePtr $ \sptr ->+ SVB.createAndTrim size $+ fmap fromIntegral .+ derefChunkPtr fill nptr sptr+ (fromIntegral size)+ (Rep.castStorablePtr aPtr) .+ Rep.castStorablePtr+ (if SV.length v > 0+ then fmap (v:)+ else id) $+ (if SV.length v < size+ then return $ SVL.chunks $+ procRest $ SVL.fromChunks $+ SV.drop (SV.length v) x : xs+ else go xs)+ go (SVL.chunks sig)++applyStorableChunky ::+ (Storable a, MakeValueTuple a valueA, Rep.Memory valueA structA,+ Storable b, MakeValueTuple b valueB, Rep.Memory valueB structB) =>+ T p valueA valueB ->+ p -> SVL.Vector a -> SVL.Vector b+applyStorableChunky gen =+ unsafePerformIO (runStorableChunky gen)
+ src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Synthesizer.LLVM.CausalParameterized.ProcessPacked where++import Synthesizer.LLVM.CausalParameterized.Process (T(Cons), )+import qualified Synthesizer.LLVM.CausalParameterized.Process as Causal+import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++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.Representation as Rep+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C+import LLVM.Extra.Control (whileLoop, ifThen, )++import LLVM.Core as LLVM++import qualified Data.TypeLevel.Num as TypeNum+import qualified Data.TypeLevel.Num.Sets as TypeSet++import qualified Control.Arrow as Arr+import Control.Arrow ((^<<), (<<<), )++-- import qualified Algebra.Transcendental as Trans+-- import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++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 ::+ (Vector.Access n a va, Vector.Access n b vb) =>+ T p a b -> T p va vb+pack (Cons next start createIOContext deleteIOContext) = Cons+ (\param a s -> do+ ((_,b2),(_,s2)) <-+ Maybe.fromBool $+ C.whileLoop+ (valueOf True,+ let b = undefTuple+ in ((a,b), (valueOf $ (fromIntegral $ Vector.sizeInTuple b :: Word32), s)))+ (\(cont,(_ab0,(i0,_s0))) ->+ A.and cont =<<+ A.icmp IntUGT i0 (value LLVM.zero))+ (\(_,((a0,b0),(i0,s0))) -> Maybe.toBool $ do+ ai <- Maybe.lift $ Vector.extract (valueOf 0) a0+ (bi,s1) <- next param ai s0+ Maybe.lift $ do+ a1 <- Vector.rotateDown a0+ b1 <- fmap snd $ Vector.shiftDown bi b0+ i1 <- A.dec i0+ return ((a1,b1),(i1,s1)))+ return (b2, s2))+ start+ 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 ::+ (Vector.Access n a va, Vector.Access n b vb) =>+ T p a b -> T p va vb+packSmall (Cons next start createIOContext deleteIOContext) = Cons+ (\param a s ->+ let vundef = LLVM.undefTuple+ in foldr+ (\i rest (v0,s0) -> do+ ai <- Maybe.lift $ Vector.extract (valueOf i) a+ (bi,s1) <- next param ai s0+ v1 <- Maybe.lift $ Vector.insert (valueOf i) bi v0+ rest (v1,s1))+ return+ (take (Vector.sizeInTuple vundef) [0..])+ (vundef, s))+ start+ 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 ::+ (Vector.Access n a va, Vector.Access n b vb,+ Class.Zero va, LLVM.Undefined b,+ Rep.Memory va vap, IsSized vap vas,+ Rep.Memory vb vbp, IsSized vbp vbs) =>+ T p va vb -> T p a b+unpack (Cons next start createIOContext deleteIOContext) = Cons+ (\param ai ((a0,b0),(i0,s0)) -> do+ endOfVector <- Maybe.lift $ A.icmp IntEQ i0 (valueOf 0)+ ((a2,b2),(i2,s2)) <-+ Maybe.fromBool $+ C.ifThen endOfVector (valueOf True, ((a0,b0),(i0,s0))) $ do+ (cont1, (b1,s1)) <- Maybe.toBool $ next param a0 s0+ return (cont1,+ ((LLVM.undefTuple, b1),+ (valueOf $ fromIntegral $ Vector.sizeInTuple a0, s1)))+ Maybe.lift $ do+ a3 <- fmap snd $ Vector.shiftDown ai a2+ (bi,b3) <- Vector.shiftDown (LLVM.undefTuple) b2+ i3 <- A.dec i2+ return (bi, ((a3,b3),(i3,s2))))+ (\p -> do+ s <- start p+ return ((Class.zeroTuple, LLVM.undefTuple), (valueOf (0::Word32), s)))+ createIOContext+ deleteIOContext+++raise ::+ (Storable a, IsArithmetic a, IsPrimitive a, IsConst a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a size,+ IsPowerOf2 n, TypeNum.Mul n size ps, TypeSet.Pos ps) =>+ Param.T p a ->+ T p (Value (Vector n a)) (Value (Vector n a))+raise x =+ Causal.map Sample.mixMono (LLVM.vector . (:[]) ^<< x)+++amplify ::+ (Storable a, IsArithmetic a, IsPrimitive a, IsConst a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a size,+ IsPowerOf2 n, TypeNum.Mul n size ps, TypeSet.Pos ps) =>+ Param.T p a ->+ T p (Value (Vector n a)) (Value (Vector n a))+amplify p =+ Causal.map Sample.amplifyMono (LLVM.vector . (:[]) ^<< p)++amplifyStereo ::+ (Storable a, IsArithmetic a, IsPrimitive a, IsConst a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a size,+ IsPowerOf2 n, TypeNum.Mul n size ps, TypeSet.Pos ps) =>+ Param.T p a ->+ T p (Stereo.T (Value (Vector n a))) (Stereo.T (Value (Vector n a)))+amplifyStereo p =+ Causal.map Sample.amplifyStereo (LLVM.vector . (:[]) ^<< p)+++osciCore ::+ (IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t,+ Vector.Real t, IsPrimitive t,+ IsPowerOf2 n,+ Additive.C t) =>+ T p (Value (Vector n t), Value (Vector n t)) (Value (Vector n t))+osciCore =+ Causal.mapSimple (uncurry SoV.addToPhase) <<<+ Arr.second+ (Causal.mapAccumSimple+ (\a phase0 -> do+ (phase1,b1) <- Vector.cumulate phase0 a+ phase2 <- SoV.signedFraction phase1+ return (b1,phase2))+ (return (valueOf Additive.zero)))++osciSimple ::+ (IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t,+ Vector.Real t, IsPrimitive t,+ IsPowerOf2 n,+ Additive.C t) =>+ (forall r. Value (Vector n t) -> CodeGenFunction r y) ->+ T p (Value (Vector n t), Value (Vector n t)) y+osciSimple wave =+ Causal.mapSimple wave <<< osciCore++shapeModOsci ::+ (IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t,+ Vector.Real t, IsPrimitive t,+ IsPowerOf2 n,+ Additive.C t) =>+ (forall r. c -> Value (Vector n t) -> CodeGenFunction r y) ->+ T p (c, (Value (Vector n t), Value (Vector n t))) y+shapeModOsci wave =+ Causal.mapSimple (uncurry wave) <<< Arr.second osciCore
+ src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.CausalParameterized.ProcessPrivate where++import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as Sig+import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified Synthesizer.LLVM.Parameter as Param+import qualified LLVM.Extra.Representation as Rep++import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Util.Loop (Phi, )+import LLVM.Core+ (Value, valueOf, MakeValueTuple,+ IsSized, IsFirstClass, IsArithmetic, CodeGenFunction, )++import qualified Control.Arrow as Arr+import qualified Control.Category as Cat+import Control.Arrow ((^<<), (<<<), (<<^), (&&&), )+import Control.Monad (liftM2, )++import qualified Algebra.Ring as Ring++import Data.Word (Word32, )+import Foreign.Storable.Tuple ()+import Foreign.Storable (Storable, )++import Data.Tuple.HT (swap, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, take, takeWhile, )+++data T p a b =+ forall state packed size ioContext+ startParamTuple startParamValue startParamPacked startParamSize+ nextParamTuple nextParamValue nextParamPacked nextParamSize.+ (Storable startParamTuple,+ Storable nextParamTuple,+ MakeValueTuple startParamTuple startParamValue,+ MakeValueTuple nextParamTuple nextParamValue,+ Rep.Memory startParamValue startParamPacked,+ Rep.Memory nextParamValue nextParamPacked,+ IsSized startParamPacked startParamSize,+ IsSized nextParamPacked nextParamSize,+ Rep.Memory state packed,+ IsSized packed size) =>+ Cons+ (forall r c.+ (Phi c) =>+ nextParamValue ->+ a -> state -> Maybe.T r c (b, state))+ -- compute next value+ (forall r.+ startParamValue ->+ CodeGenFunction r state)+ -- initial state+ (p -> IO (ioContext, (nextParamTuple, startParamTuple)))+ {- initialization from IO monad+ This will be run within unsafePerformIO,+ so no observable In/Out actions please!+ -}+ (ioContext -> IO ())+ -- finalization from IO monad, also run within unsafePerformIO+++simple ::+ (Storable startParamTuple,+ Storable nextParamTuple,+ MakeValueTuple startParamTuple startParamValue,+ MakeValueTuple nextParamTuple nextParamValue,+ Rep.Memory startParamValue startParamPacked,+ Rep.Memory nextParamValue nextParamPacked,+ IsSized startParamPacked startParamSize,+ IsSized nextParamPacked nextParamSize,+ Rep.Memory state packed,+ IsSized packed size) =>+ (forall r c.+ (Phi c) =>+ nextParamValue ->+ a -> state -> Maybe.T r c (b, state)) ->+ (forall r.+ startParamValue ->+ CodeGenFunction r state) ->+ Param.T p nextParamTuple ->+ Param.T p startParamTuple -> T p a b+simple f start selectParam initial = Cons+ (f . Param.value selectParam)+ (start . Param.value initial)+ (return . (,) () . Param.get (selectParam &&& initial))+ (const $ return ())+++toSignal :: T p () a -> Sig.T p a+toSignal (Cons next start createIOContext deleteIOContext) = Sig.Cons+ (\ioContext -> next ioContext ())+ start+ createIOContext deleteIOContext++fromSignal :: Sig.T p a -> T p () a+fromSignal (Sig.Cons next start createIOContext deleteIOContext) = Cons+ (\ioContext () -> next ioContext)+ start+ createIOContext deleteIOContext+++mapAccum ::+ (Storable pnh, MakeValueTuple pnh pnl, Rep.Memory pnl pnp, IsSized pnp pns,+ Storable psh, MakeValueTuple psh psl, Rep.Memory psl psp, IsSized psp pss,+ Rep.Memory s struct, IsSized struct sa) =>+ (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 b+mapAccum next start selectParamN selectParamS =+ simple+ (\p a s -> Maybe.lift $ next p a s)+ start+ selectParamN selectParamS+++map ::+ (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) =>+ (forall r. pl -> a -> CodeGenFunction r b) ->+ Param.T p ph ->+ T p a b+map f selectParamF =+ mapAccum+ (\p a s -> fmap (flip (,) s) $ f p a)+ (const $ return ())+ selectParamF+ (return ())++mapSimple ::+ (forall r. a -> CodeGenFunction r b) ->+ T p a b+mapSimple f =+ map (const f) (return ())+++apply :: T p a b -> Sig.T p a -> Sig.T p b+apply proc sig =+ toSignal (proc <<< fromSignal sig)++feedFst :: Sig.T p a -> T p b (a,b)+feedFst sig =+ first (fromSignal sig) <<^ (\b -> ((),b))++feedSnd :: Sig.T p a -> T p b (b,a)+feedSnd sig =+ swap ^<< feedFst sig+++{-+Very similar to 'apply',+since 'apply' can be considered being of type+@T p a b -> T p () a -> T p () b@.+-}+compose :: T p a b -> T p b c -> T p a c+compose+ (Cons nextA startA createIOContextA deleteIOContextA)+ (Cons nextB startB createIOContextB deleteIOContextB) =+ Cons+ (\(paramA, paramB) a (sa0,sb0) ->+ do (b,sa1) <- nextA paramA a sa0+ (c,sb1) <- nextB paramB b sb0+ return (c, (sa1,sb1)))+ (\(paramA, paramB) ->+ liftM2 (,)+ (startA paramA)+ (startB paramB))+ (\p -> do+ (ca,(nextParamA,startParamA)) <- createIOContextA p+ (cb,(nextParamB,startParamB)) <- createIOContextB p+ return ((ca,cb),+ ((nextParamA, nextParamB),+ (startParamA, startParamB))))+ (\(ca,cb) ->+ deleteIOContextA ca >>+ deleteIOContextB cb)+++first :: T p b c -> T p (b, d) (c, d)+first (Cons next start createIOContext deleteIOContext) = Cons+ (\ioContext (b,d) sa0 ->+ do (c,sa1) <- next ioContext b sa0+ return ((c,d), sa1))+ start+ createIOContext deleteIOContext+++instance Cat.Category (T p) where+ id = mapSimple return+ (.) = flip compose++instance Arr.Arrow (T p) where+ arr f = mapSimple (return . f)+ first = first+++takeWhile ::+ (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) =>+ (forall r. pl -> a -> CodeGenFunction r (Value Bool)) ->+ Param.T p ph ->+ T p a a+takeWhile check selectParam = simple+ (\p a () -> do+ Maybe.guard =<< Maybe.lift (check p a)+ return (a, ()))+ return+ selectParam+ (return ())+++take ::+ Param.T p Int ->+ T p a a+take len =+ snd ^<<+ takeWhile (const $ A.icmp LLVM.IntULT (valueOf 0) . fst) (return ()) <<<+ feedFst+ (Sig.iterate (const A.dec) (return ())+ ((fromIntegral :: Int -> Word32) . max 0 ^<< len))+++{- |+The first output value is the start value.+Thus 'integrate' delays by one sample compared with 'integrate0'.+-}+integrate ::+ (Storable a, IsArithmetic a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+ Param.T p a ->+ T p (Value a) (Value a)+integrate =+ mapAccum+ (\() a s -> do+ b <- A.add a s+ return (s,b))+ return+ (return ())++integrate0 ::+ (Storable a, IsArithmetic a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+ Param.T p a ->+ T p (Value a) (Value a)+integrate0 =+ mapAccum+ (\() a s -> do+ b <- A.add a s+ return (b,b))+ return+ (return ())
+ src/Synthesizer/LLVM/EventIterator.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Synthesizer.LLVM.EventIterator where++import qualified Data.EventList.Relative.BodyTime as EventList+import qualified Numeric.NonNegative.Wrapper as NonNeg++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 Data.IORef (IORef, newIORef, readIORef, writeIORef, )+++data T =+ forall a. Storable a =>+ Cons (IORef (EventList.T NonNeg.Int a))++{-+For problems about Storable constraint, see ChunkIterator.+-}+foreign import ccall "&nextConstant"+ nextCallBack ::+ FunPtr (+ StablePtr T ->+ Ptr a -> IO Word32+ )++foreign export ccall "nextConstant"+ next ::+ StablePtr T ->+ Ptr a -> IO Word32+++{- |+Events with subsequent duration 0 are ignored+(and for performance reasons it should not contain too many small values,+say below 100).+-}+new ::+ Storable a =>+ EventList.T NonNeg.Int a -> IO (StablePtr T)+new evs =+ newStablePtr . Cons+ =<< newIORef+ (EventList.fromPairList $+ filter ((/=0) . snd) $+ EventList.toPairList evs)++dispose ::+ StablePtr T -> IO ()+dispose = freeStablePtr++next ::+ StablePtr T ->+ Ptr a -> IO Word32+next stable eventPtr =+ deRefStablePtr stable >>= \state ->+ case state of+ Cons listRef ->+ readIORef listRef >>=+ EventList.switchL+ (return 0)+ (\body time xs ->+ writeIORef listRef xs >>+ poke (castPtr eventPtr) body >>+ return (fromIntegral time))
+ src/Synthesizer/LLVM/Execution.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Synthesizer.LLVM.Execution where++import LLVM.Core+ (CodeGenModule, newModule, defineModule, getGlobalMappings, Function,+ writeBitcodeToFile, )+import LLVM.ExecutionEngine+ (EngineAccess, runEngineAccess,+ Translatable, generateFunction,+ addModule, getPointerToFunction, addGlobalMappings, )+import LLVM.Util.Optimize (optimizeModule, )++import Foreign.Ptr (FunPtr, )++import Control.Monad (liftM2, liftM3, )++import qualified Data.List.HT as ListHT+import qualified Data.IORef as IORef+import System.IO.Unsafe (unsafePerformIO, )+++type Importer f = FunPtr f -> f++class Compile externFunction llvmFunction |+ externFunction -> llvmFunction,+ llvmFunction -> externFunction where+ compile :: llvmFunction -> EngineAccess externFunction++instance Compile (FunPtr f) (Function f) where+ compile = getPointerToFunction++instance (Compile efa lfa, Compile efb lfb) =>+ Compile (efa,efb) (lfa,lfb) where+ compile (fa,fb) =+ liftM2 (,)+ (compile fa)+ (compile fb)++instance (Compile efa lfa, Compile efb lfb, Compile efc lfc) =>+ Compile (efa,efb,efc) (lfa,lfb,lfc) where+ compile (fa,fb,fc) =+ liftM3 (,,)+ (compile fa)+ (compile fb)+ (compile fc)+++{- |+This is only for debugging purposes+and thus I felt free to use unsafePerformIO.+-}+counter :: IORef.IORef Int+counter =+ unsafePerformIO $ IORef.newIORef 0+++assembleModule ::+ (llvmFunction -> EngineAccess externFunction) ->+ CodeGenModule llvmFunction ->+ IO externFunction+assembleModule comp bld = do+ m <- newModule+ (funcs, mappings) <-+ defineModule m (liftM2 (,) bld getGlobalMappings)++ -- write bitcode files for debugging+ num <- fmap (ListHT.padLeft '0' 3 . show) (IORef.readIORef counter)+ IORef.modifyIORef counter succ++ writeBitcodeToFile ("generator"++num++".bc") m++ optimizeModule 3 m++ writeBitcodeToFile ("generator"++num++"-opt.bc") m++ runEngineAccess $+ addModule m >>+ addGlobalMappings mappings >>+ comp funcs+++-- this compiles once and is much faster than runFunction+compileModule ::+ (Compile externFunction llvmFunction) =>+ CodeGenModule llvmFunction ->+ IO externFunction+compileModule =+ assembleModule compile++runFunction ::+ (Translatable f) =>+ CodeGenModule (Function f) -> IO f+runFunction =+ assembleModule generateFunction
+ src/Synthesizer/LLVM/Filter/Allpass.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Synthesizer.LLVM.Filter.Allpass (+ Parameter, parameter,+ CascadeParameter, flangerParameter, flangerParameterPlain,+ causalP, cascadeP, phaserP,+ cascadePipelineP, phaserPipelineP,+ causalPackedP, cascadePackedP, phaserPackedP,+ ) where++import Synthesizer.Plain.Filter.Recursive.Allpass (Parameter(Parameter), )+import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1++import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1L+import qualified Synthesizer.Plain.Modifier as Modifier++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Representation as Rep+import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, valueOf, Vector,+ IsPowerOf2, IsConst, IsArithmetic, IsPrimitive, IsFirstClass, IsFloating, IsSized,+ Undefined, undefTuple,+ CodeGenFunction, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import qualified Data.TypeLevel.Num as TypeNum+import qualified Data.TypeLevel.Num.Sets as TypeSet++import Foreign.Storable (Storable, )++import qualified Control.Category as Cat+import qualified Control.Applicative as App+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav+import Control.Arrow ((<<<), (^<<), (<<^), (&&&), arr, first, second, )++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field as Field+import qualified Algebra.Module as Module+import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric+import NumericPrelude.Base+++instance (Phi a) => Phi (Parameter a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable++instance Undefined a => Undefined (Parameter a) where+ undefTuple = Class.undefTuplePointed++instance Class.Zero a => Class.Zero (Parameter a) where+ zeroTuple = Class.zeroTuplePointed++instance+ (Rep.Memory a s, IsSized s ss) =>+ Rep.Memory (Parameter a) s where+ load = Rep.loadNewtype Parameter+ store = Rep.storeNewtype (\(Parameter k) -> k)+ decompose = Rep.decomposeNewtype Parameter+ compose = Rep.composeNewtype (\(Parameter k) -> k)+++instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where+ buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)++instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where+ tupleDesc = Class.tupleDescFoldable++instance (LLVM.MakeValueTuple ah al) =>+ LLVM.MakeValueTuple (Parameter ah) (Parameter al) where+ valueTupleOf = Class.valueTupleOfFunctor+++instance (Value.Flatten ah al) =>+ Value.Flatten (Parameter ah) (Parameter al) where+ flatten = Value.flattenTraversable+ unfold = Value.unfoldFunctor+++instance (Vector.ShuffleMatch n v) =>+ Vector.ShuffleMatch n (Parameter v) where+ shuffleMatch = Vector.shuffleMatchTraversable++instance (Vector.Access n a v) =>+ Vector.Access n (Parameter a) (Parameter v) where+ insert = Vector.insertTraversable+ extract = Vector.extractTraversable+++parameter ::+ (Trans.C a, IsConst a, IsFloating a) =>+ Value a -> Value a ->+ CodeGenFunction r (Parameter (Value a))+parameter phase freq =+ Value.flatten $+ Allpass.parameter+ (Value.constantValue phase) (Value.constantValue freq)+++newtype CascadeParameter n a =+ CascadeParameter (Allpass.Parameter a)+ deriving+ (Phi, Undefined, Class.Zero, Storable,+ Functor, App.Applicative, Fold.Foldable, Trav.Traversable)++instance+ (Rep.Memory a s, IsSized s ss) =>+ Rep.Memory (CascadeParameter n a) s where+ load = Rep.loadNewtype CascadeParameter+ store = Rep.storeNewtype (\(CascadeParameter k) -> k)+ decompose = Rep.decomposeNewtype CascadeParameter+ compose = Rep.composeNewtype (\(CascadeParameter k) -> k)+++instance LLVM.ValueTuple a => LLVM.ValueTuple (CascadeParameter n a) where+ buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)++instance LLVM.IsTuple a => LLVM.IsTuple (CascadeParameter n a) where+ tupleDesc = Class.tupleDescFoldable++instance (LLVM.MakeValueTuple ah al) =>+ LLVM.MakeValueTuple (CascadeParameter n ah) (CascadeParameter n al) where+ valueTupleOf = Class.valueTupleOfFunctor+++instance (Value.Flatten ah al) =>+ Value.Flatten (CascadeParameter n ah) (CascadeParameter n al) where+ flatten = Value.flattenTraversable+ unfold = Value.unfoldFunctor+++instance (Vector.ShuffleMatch m v) =>+ Vector.ShuffleMatch m (CascadeParameter n v) where+ shuffleMatch = Vector.shuffleMatchTraversable++instance (Vector.Access m a v) =>+ Vector.Access m (CascadeParameter n a) (CascadeParameter n v) where+ insert = Vector.insertTraversable+ extract = Vector.extractTraversable+++flangerParameter ::+ (Trans.C a, IsConst a, IsFloating a, TypeNum.Nat n) =>+ n -> Value a ->+ CodeGenFunction r (CascadeParameter n (Value a))+flangerParameter order freq =+ Value.flatten $+ CascadeParameter $+ Allpass.flangerParameter (TypeNum.toInt order) $+ Value.constantValue freq++flangerParameterPlain ::+ (Trans.C a, TypeNum.Nat n) =>+ n -> a -> CascadeParameter n a+flangerParameterPlain order freq =+ CascadeParameter $+ Allpass.flangerParameter (TypeNum.toInt order) freq+++modifier ::+ (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) =>+ Modifier.Simple+ -- (Allpass.State (Value.T v))+ (Value.T v, Value.T v)+ (Parameter (Value.T a))+ (Value.T v) (Value.T v)+modifier =+ Allpass.firstOrderModifier++{-+For Allpass cascade you may use the 'CausalP.pipeline' function.+-}+causalP ::+ (Field.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a,+ IsFirstClass v, IsSized v vs, IsConst v,+ IsArithmetic a) =>+ CausalP.T p+ (Parameter (Value a), Value v) (Value v)+causalP =+ CausalP.fromModifier modifier+++replicateStage ::+ (TypeNum.Nat n) =>+ n ->+ CausalP.T p (Parameter a, b) b ->+ CausalP.T p (CascadeParameter n a, b) b+replicateStage order stg =+ CausalP.replicateControlled+ (TypeNum.toInt order)+ (stg <<< first (arr (\(CascadeParameter p) -> p)))++cascadeP ::+ (Field.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a,+ IsFirstClass v, IsSized v vs, IsConst v,+ IsArithmetic a,+ TypeNum.Nat n) =>+ CausalP.T p+ (CascadeParameter n (Value a), Value v) (Value v)+cascadeP =+ replicateStage undefined causalP++half ::+ (Field.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a,+ IsFirstClass v, IsSized v vs, IsConst v,+ IsFloating a, IsArithmetic v,+ TypeNum.Nat n) =>+ CausalP.T p+ (CascadeParameter n (Value a), Value v) (Value v)+half =+ CausalP.mapSimple (\(p,x) ->+ Value.decons+ ((const :: Value.T a -> CascadeParameter n (Value a) -> Value.T a) 0.5 p *>+ Value.constantValue x))++phaserP ::+ (Field.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a,+ IsFirstClass v, IsSized v vs, IsConst v,+ IsFloating a, IsArithmetic v,+ TypeNum.Nat n) =>+ CausalP.T p+ (CascadeParameter n (Value a), Value v) (Value v)+phaserP =+ CausalP.mix <<<+ cascadeP &&& arr snd <<<+ (arr fst &&& half)+++{-+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 ::+ (IsPowerOf2 n, IsPrimitive a, IsFirstClass a,+ IsConst a, IsArithmetic a, Ring.C a,+ IsSized a sa) =>+ n ->+ CausalP.T p+ (CascadeParameter n (Value (Vector n a)), Value (Vector n a))+ (CascadeParameter n (Value (Vector n a)), Value (Vector n a))+stage _ =+ CausalP.vectorize+ (arr fst &&&+ (CausalP.fromModifier modifier <<<+ first (arr (\(CascadeParameter p) -> p))))++withSize ::+ (n -> CausalP.T p (CascadeParameter n a, b) c) ->+ CausalP.T p (CascadeParameter n a, b) c+withSize f = f undefined++{- |+Fast implementation of 'cascadeP' using vector instructions.+However, we are currently limited to powers of two,+primitive element types+and we get a delay by the number of pipeline stages.+-}+cascadePipelineP ::+ (Field.C a, IsFirstClass a, IsSized a as,+ TypeNum.Mul n as vas, TypeSet.Pos vas,+-- IsSized (Vector n a) vas,+ IsPowerOf2 n,+ IsArithmetic a, IsPrimitive a, IsConst a) =>+ CausalP.T p+ (CascadeParameter n (Value a), Value a) (Value a)+cascadePipelineP = withSize $ \order ->+ snd ^<< CausalP.pipeline (stage order)++vectorId ::+ (Vector.Access n a v) =>+ n -> CausalP.T p v v+vectorId _ = Cat.id++phaserPipelineP ::+ (Field.C a,+ IsFirstClass a, IsSized a as,+ IsSized (Vector n a) vas,+ TypeNum.Mul n as vas,+ IsPowerOf2 n,+ IsFloating a, IsPrimitive a, IsConst a) =>+ CausalP.T p+ (CascadeParameter n (Value a), Value a) (Value a)+phaserPipelineP = withSize $ \order ->+ CausalP.mix <<<+ cascadePipelineP &&&+ (CausalP.pipeline (vectorId order) <<^ snd) <<<+-- (CausalP.delay (const zero) (const $ TypeNum.toInt order) <<^ snd) <<<+ (arr fst &&& half)+++causalPackedP,+ causalNonRecursivePackedP ::+ (Ring.C a,+ IsFirstClass a, IsArithmetic a, IsConst a,+ IsPowerOf2 n, IsPrimitive a, IsSized a as) =>+ CausalP.T p+ (Parameter (Value a), Value (Vector n a)) (Value (Vector n a))+causalPackedP =+ Filt1L.causalRecursivePackedP <<<+ (CausalP.mapSimple+ (\(Parameter k, _) ->+ fmap Filt1.Parameter $ LLVM.neg k) &&&+ causalNonRecursivePackedP)++causalNonRecursivePackedP =+ CausalP.mapAccumSimple+ (\(Parameter k, v0) x1 -> do+ (_,v1) <- Vector.shiftUp x1 v0+ y <- A.add v1 =<< A.mul v0 =<< SoV.replicate k+ let size = fromIntegral $ Vector.sizeInTuple v0+ u0 <- Vector.extract (valueOf $ size - 1) v0+ return (y, u0))+ (return (LLVM.value LLVM.zero))++cascadePackedP, phaserPackedP ::+ (Field.C a,+ IsFirstClass a, IsArithmetic a, IsConst a,+ IsPowerOf2 m, IsPrimitive a, IsSized a as,+ TypeNum.Nat n) =>+ CausalP.T p+ (CascadeParameter n (Value a), Value (Vector m a)) (Value (Vector m a))+cascadePackedP =+ replicateStage undefined causalPackedP++phaserPackedP =+ CausalP.mix <<<+ cascadePackedP &&& arr snd <<<+ second (CausalP.mapSimple (A.mul (SoV.replicateOf 0.5)))
+ src/Synthesizer/LLVM/Filter/Butterworth.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.LLVM.Filter.Butterworth (+ parameter, Cascade.ParameterValue,+ Cascade.causalP, Cascade.causalPackedP,+ Cascade.fixSize,+ ) where++import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade++import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butterworth+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2+import Synthesizer.Plain.Filter.Recursive (Passband, )++import qualified LLVM.Extra.Control as U+import qualified LLVM.Extra.Representation as Rep+import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, valueOf, constOf,+ IsConst, IsFloating, IsSized,+ CodeGenFunction, )+import Data.Word (Word32, )++import qualified Data.TypeLevel.Num as TypeNum+import qualified Data.TypeLevel.Num.Sets as TypeSet++import qualified Algebra.Transcendental as Trans+-- import qualified Algebra.Field as Field+-- import qualified Algebra.Module as Module+-- import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric+import NumericPrelude.Base+++parameter, parameterMalloc, _parameterAlloca ::+ (Trans.C a, IsConst a, IsFloating a, IsSized a as,+ TypeSet.Nat n,+ TypeNum.Mul n as sineSize,+ TypeSet.Pos sineSize,+ IsSized (Cascade.Parameter n a) paramSize) =>+ n -> Passband -> Value a -> Value a ->+ CodeGenFunction r (Cascade.ParameterValue n a)+parameter = parameterMalloc++parameterMalloc n kind ratio freq = do+ let order = 2 * TypeNum.toInt n+ partialRatio <-+ Value.decons (Butterworth.partialRatio order (Value.constantValue ratio))+ let sines =+ (flip const :: n -> LLVM.Value (LLVM.Array n a)+ -> LLVM.Value (LLVM.Array n a)) n $+ LLVM.value $+ LLVM.constArray $+ 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 $ (fromIntegral $ TypeNum.toInt n :: Word32)+ U.arrayLoop len p s $ \ptri si -> do+ sinw <- LLVM.load si+ flip Rep.store ptri =<<+ Value.flatten+ (Filt2.adjustPassband kind+ (flip+ (Butterworth.partialParameter+ (Value.constantValue partialRatio))+ (Value.constantValue sinw))+ (Value.constantValue freq))+ A.advanceArrayElementPtr si+ pv <- LLVM.load ps+ LLVM.free psine+ LLVM.free ps+ return (Cascade.ParameterValue pv)++_parameterAlloca n kind ratio freq = do+ let order = 2 * TypeNum.toInt n+ partialRatio <-+ Value.decons (Butterworth.partialRatio order (Value.constantValue ratio))+ let sines =+ (flip const :: n -> LLVM.Value (LLVM.Array n a)+ -> LLVM.Value (LLVM.Array n a)) n $+ LLVM.value $+ LLVM.constArray $+ 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 $ (fromIntegral $ TypeNum.toInt n :: Word32)+ U.arrayLoop len p s $ \ptri si -> do+ sinw <- LLVM.load si+ flip Rep.store ptri =<<+ Value.flatten+ (Filt2.adjustPassband kind+ (flip+ (Butterworth.partialParameter+ (Value.constantValue partialRatio))+ (Value.constantValue sinw))+ (Value.constantValue freq))+ A.advanceArrayElementPtr si+ fmap Cascade.ParameterValue $ LLVM.load ps
+ src/Synthesizer/LLVM/Filter/Chebyshev.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.LLVM.Filter.Chebyshev (+ parameterA, parameterB, Cascade.ParameterValue,+ Cascade.causalP, Cascade.causalPackedP,+ Cascade.fixSize,+ ) where++import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade++import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Chebyshev+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2+import Synthesizer.Plain.Filter.Recursive (Passband, )++import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Control as U++import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, valueOf, ConstValue,+ Struct, IsSized, IsConst, IsFloating,+ CodeGenFunction, )+import Data.Word (Word32, )++import qualified Data.TypeLevel.Num as TypeNum+import qualified Data.TypeLevel.Num.Sets as TypeSet++import qualified Number.Complex as Complex++import qualified Algebra.Transcendental as Trans+-- import qualified Algebra.Field as Field+-- import qualified Algebra.Module as Module+import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric+import NumericPrelude.Base+++constComplexOf :: IsConst a =>+ Complex.T a -> ConstValue (Struct (a, (a, ())))+constComplexOf x =+ LLVM.constStruct+ (LLVM.constOf $ Complex.real x,+ (LLVM.constOf $ Complex.imag x,+ ()))++valueComplex ::+ Value (Struct (a, (a, ()))) -> Complex.T (Value.T a)+valueComplex x =+ Value.Cons (LLVM.extractvalue x TypeNum.d0)+ Complex.+:+ Value.Cons (LLVM.extractvalue x TypeNum.d1)+++{- |+'n' must be at least one in order to allow amplification+by the first partial filter.+-}+parameterA, parameterB ::+ (Trans.C a, IsConst a, IsFloating a, IsSized a as,+ TypeSet.Pos n,+ TypeNum.Mul n as sineSize,+ TypeSet.Pos sineSize,+ IsSized (Cascade.Parameter n a) paramSize,+ TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) =>+ 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++ -- adjust amplification of the first filter+ filt0 <-+ Rep.decompose =<<+ LLVM.extractvalue pv (0::Word32)+ fmap Cascade.ParameterValue $+ flip (LLVM.insertvalue pv) (0::Word32) =<<+ Rep.compose =<<+ Value.flatten+ (Filt2.amplify (Value.constantValue ratio) (Value.unfold filt0))++parameterB n kind ratio freq =+ fmap Cascade.ParameterValue $+ parameter Chebyshev.partialParameterB n kind ratio freq+++parameter ::+ (Trans.C a, IsConst a, IsFloating a, IsSized a as,+ TypeSet.Pos n,+ TypeNum.Mul n as sineSize,+ TypeSet.Pos sineSize,+ IsSized (Cascade.Parameter n a) paramSize,+ TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) =>+ (Int -> Value.T a -> Value.T a ->+ Complex.T (Value.T a) -> Filt2.Parameter (Value.T a)) ->+ n -> Passband -> Value a -> Value a ->+ CodeGenFunction r (Value (Cascade.Parameter n a))+parameter partialParameter n kind ratio freq = do+ let order = 2 * TypeNum.toInt n+ let sines =+ (flip const :: n -> LLVM.Value (LLVM.Array n a)+ -> LLVM.Value (LLVM.Array n a)) n $+ LLVM.value $+ LLVM.constArray $+ map constComplexOf $+ Chebyshev.makeCirclePoints 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 $ (fromIntegral $ TypeNum.toInt n :: Word32)+ U.arrayLoop len p s $ \ptri si -> do+ c <- LLVM.load si+ flip Rep.store ptri =<<+ Value.flatten+ (Filt2.adjustPassband kind+ (flip+ (partialParameter order+ (Value.constantValue ratio))+ (valueComplex c))+ (Value.constantValue freq))+ A.advanceArrayElementPtr si++ pv <- LLVM.load ps+ LLVM.free psine+ LLVM.free ps+ return pv
+ src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Filter.ComplexFirstOrder (+ Parameter, parameter,+ causal, causalP,+ ) where++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified LLVM.Extra.Representation as Rep+import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Core+ (value, valueOf, Value, Struct,+ IsFirstClass, IsConst, IsArithmetic, IsFloating, IsSized,+ Undefined, undefTuple,+ CodeGenFunction, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import Data.TypeLevel.Num (d0, d1, d2, )++import Control.Applicative (liftA3, )++import qualified Algebra.Transcendental as Trans++import NumericPrelude.Numeric+import NumericPrelude.Base+++data Parameter a =+ Parameter a (a,a)++instance (Phi a) => Phi (Parameter a) where+ phis bb (Parameter k (r,i)) = do+ k' <- phis bb k+ r' <- phis bb r+ i' <- phis bb i+ return (Parameter k' (r',i'))+ addPhis bb+ (Parameter k (r,i))+ (Parameter k' (r',i')) = do+ addPhis bb k k'+ addPhis bb r r'+ addPhis bb i i'++instance Undefined a => Undefined (Parameter a) where+ undefTuple = Parameter undefTuple (undefTuple,undefTuple)+++parameterMemory ::+ (Rep.Memory l s, IsSized s ss) =>+ Rep.MemoryRecord r (Struct (s, (s, (s, ())))) (Parameter l)+parameterMemory =+ liftA3 (\amp kr ki -> Parameter amp (kr,ki))+ (Rep.memoryElement (\(Parameter amp (_kr,_ki)) -> amp) d0)+ (Rep.memoryElement (\(Parameter _amp ( kr,_ki)) -> kr) d1)+ (Rep.memoryElement (\(Parameter _amp (_kr, ki)) -> ki) d2)++instance (Rep.Memory l s, IsSized s ss) =>+ Rep.Memory (Parameter l) (Struct (s, (s, (s, ())))) where+ load = Rep.loadRecord parameterMemory+ store = Rep.storeRecord parameterMemory+ decompose = Rep.decomposeRecord parameterMemory+ compose = Rep.composeRecord parameterMemory++parameter ::+ (Trans.C a,+ IsConst a, IsFloating a) =>+ Value a -> Value a -> CodeGenFunction r (Parameter (Value a))+parameter reson freq = do+ amp <- A.fdiv (valueOf 1) reson+ k <- A.sub (valueOf 1) amp+ w <- A.mul freq =<< Value.decons Value.twoPi+ kr <- A.mul k =<< A.cos w+ ki <- A.mul k =<< A.sin w+ return (Parameter amp (kr,ki))+++next ::+ (IsArithmetic a, IsConst a) =>+ (Parameter (Value a), Stereo.T (Value a)) ->+ (Value a, Value a) ->+ CodeGenFunction r (Stereo.T (Value a), (Value a, Value a))+next (Parameter amp (kr,ki), x) (sr,si) = do+ yr <- Value.decons $+ Value.Cons (A.mul (Stereo.left x) amp) ++ Value.Cons (A.mul kr sr) - Value.Cons (A.mul ki si)+ yi <- Value.decons $+ Value.Cons (A.mul (Stereo.right x) amp) ++ Value.Cons (A.mul kr si) + Value.Cons (A.mul ki sr)+ return (Stereo.cons yr yi, (yr, yi))++start ::+ (LLVM.IsType a, IsConst a) =>+ CodeGenFunction r (Value a, Value a)+start =+ return (value LLVM.zero, value LLVM.zero)++causal ::+ (IsFirstClass a, IsSized a sa, IsConst a,+ IsFloating a) =>+ Causal.T+ (Parameter (Value a), Stereo.T (Value a))+ (Stereo.T (Value a))+causal =+ Causal.mapAccum next start++causalP ::+ (IsFirstClass a, IsSized a sa, IsConst a,+ IsFloating a) =>+ CausalP.T p+ (Parameter (Value a), Stereo.T (Value a))+ (Stereo.T (Value a))+causalP =+ CausalP.mapAccumSimple next start
+ src/Synthesizer/LLVM/Filter/ComplexFirstOrderPacked.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Filter.ComplexFirstOrderPacked (+ Parameter, parameter,+ causal, causalP,+ ) where++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified LLVM.Extra.Representation as Rep+import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified LLVM.Extra.Vector as Vector++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, valueOf, value, Struct,+ IsPrimitive, IsConst, IsFloating, IsSized,+ Undefined, undefTuple,+ Vector, insertelement,+ neg, CodeGenFunction, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import Data.TypeLevel.Num (Add, D4, d0, d1, )+import qualified Data.TypeLevel.Num.Sets as Sets++import Control.Applicative (liftA2, )++import qualified Algebra.Transcendental as Trans+-- import qualified Algebra.Field as Field+-- import qualified Algebra.Ring as Ring+-- import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric+import NumericPrelude.Base+++-- the pair should also be replaced by a Vector+data Parameter a =+ Parameter (Value (Vector D4 a)) (Value (Vector D4 a))++instance IsPrimitive a => Phi (Parameter a) where+ phis bb (Parameter r i) = do+ r' <- phis bb r+ i' <- phis bb i+ return (Parameter r' i')+ addPhis bb+ (Parameter r i)+ (Parameter r' i') = do+ addPhis bb r r'+ addPhis bb i i'++instance IsPrimitive a => Undefined (Parameter a) where+ undefTuple = Parameter undefTuple undefTuple+++parameterMemory ::+ (IsPrimitive l, IsSized l s, Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) =>+ Rep.MemoryRecord r (Struct (Vector D4 l, (Vector D4 l, ()))) (Parameter l)+parameterMemory =+ liftA2 Parameter+ (Rep.memoryElement (\(Parameter kr _) -> kr) d0)+ (Rep.memoryElement (\(Parameter _ ki) -> ki) d1)++{-+The complicated Add constraints are caused by the IsType superclass of Memory.++instance (IsPrimitive l, IsSized (Vector D4 l) ss) =>+ Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where++Mul constraint seems to be not enough, GHC urges to give constraints in terms of Add+instance (IsPrimitive l, IsSized l s, Mul D4 s ss, Sets.Pos ss) =>+ Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where+-}+instance (IsPrimitive l, IsSized l s, Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) =>+ Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where+ load = Rep.loadRecord parameterMemory+ store = Rep.storeRecord parameterMemory+ decompose = Rep.decomposeRecord parameterMemory+ compose = Rep.composeRecord parameterMemory++parameter ::+ (Trans.C a,+ IsPrimitive a, IsConst a, IsFloating a) =>+ Value a -> Value a -> CodeGenFunction r (Parameter a)+parameter reson freq = do+ amp <- A.fdiv (valueOf 1) reson+ k <- A.sub (valueOf 1) amp+ w <- A.mul freq =<< Value.decons Value.twoPi+ kr <- A.mul k =<< A.cos w+ ki <- A.mul k =<< A.sin w++ kin <- neg ki+ kvr <- Vector.assemble [kr,kin,amp, value LLVM.zero]+ kvi <- Vector.assemble [ki,kr, amp, value LLVM.zero]+ return (Parameter kvr kvi)++{-+The handling of Vector D2 Float in LLVM-2.5 and LLVM-2.6 is at least unexpected.+Because of compatibility reasons, LLVM chooses MMX registers+which requires to call EMMS occasionally.+Thus I choose Vector D4 for Float computations.+Actually, I have now rearranged the data+such that we can make use of SSE4's dot product operation.+This would even require a vector of size 3.+-}+next ::+ (Vector.Arithmetic a, IsConst a) =>+ (Parameter a, Stereo.T (Value a)) ->+ (Value (Vector D4 a)) ->+ CodeGenFunction r (Stereo.T (Value a), (Value (Vector D4 a)))+next (Parameter kr ki, x) s = do+ sr <- insertelement s (Stereo.left x) (valueOf 2)+ yr <- Vector.dotProduct kr sr++ si <- insertelement s (Stereo.right x) (valueOf 2)+ yi <- Vector.dotProduct ki si++ sv <- Vector.assemble [yr,yi]+ return (Stereo.cons yr yi, sv)++start ::+ (IsPrimitive a, IsConst a) =>+ CodeGenFunction r (Value (Vector D4 a))+start =+ return (value LLVM.zero)++causal ::+ (IsConst a, Vector.Arithmetic a,+ IsSized (Vector D4 a) as) =>+ Causal.T+ (Parameter a, Stereo.T (Value a))+ (Stereo.T (Value a))+causal =+ Causal.mapAccum next start++causalP ::+ (IsConst a, Vector.Arithmetic a,+ IsSized (Vector D4 a) as) =>+ CausalP.T p+ (Parameter a, Stereo.T (Value a))+ (Stereo.T (Value a))+causalP =+ CausalP.mapAccumSimple next start
+ src/Synthesizer/LLVM/Filter/FirstOrder.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Synthesizer.LLVM.Filter.FirstOrder (+ Result(Result,lowpass_,highpass_), Parameter, parameter,+ causalP, lowpassCausalP, highpassCausalP,+ causalPackedP, lowpassCausalPackedP, highpassCausalPackedP,+ causalRecursivePackedP, -- for Allpass+ ) where++import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder+import Synthesizer.Plain.Filter.Recursive.FirstOrder+ (Parameter(Parameter), Result(Result,lowpass_,highpass_))++import qualified Synthesizer.Plain.Modifier as Modifier++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector+import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, valueOf, Vector, Undefined, undefTuple,+ IsFirstClass, IsConst, IsArithmetic, IsFloating,+ IsPrimitive, IsPowerOf2, IsSized,+ CodeGenFunction, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import Control.Arrow (arr, (&&&), (<<<), )+import Control.Monad (liftM2, foldM, )++import qualified Algebra.Transcendental as Trans+-- import qualified Algebra.Field as Field+import qualified Algebra.Module as Module+import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric+import NumericPrelude.Base+++instance (Phi a) => Phi (Parameter a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable++instance Undefined a => Undefined (Parameter a) where+ undefTuple = Class.undefTuplePointed++instance+ (Rep.Memory a s, IsSized s ss) =>+ Rep.Memory (Parameter a) s where+ load = Rep.loadNewtype Parameter+ store = Rep.storeNewtype (\(Parameter k) -> k)+ decompose = Rep.decomposeNewtype Parameter+ compose = Rep.composeNewtype (\(Parameter k) -> k)++instance (Value.Flatten ah al) =>+ Value.Flatten (Parameter ah) (Parameter al) where+ flatten = Value.flattenTraversable+ unfold = Value.unfoldFunctor++instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where+ buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)++instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where+ tupleDesc = Class.tupleDescFoldable++instance (LLVM.MakeValueTuple ah al) =>+ LLVM.MakeValueTuple (Parameter ah) (Parameter al) where+ valueTupleOf = Class.valueTupleOfFunctor+++parameter ::+ (Trans.C a, IsConst a, IsFloating a) =>+ Value a ->+ CodeGenFunction r (Parameter (Value a))+parameter reson =+ Value.flatten $+ FirstOrder.parameter+ (Value.constantValue reson)+++lowpassModifier, highpassModifier ::+ (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) =>+ Modifier.Simple+-- (FirstOrder.State (Value.T v))+ (Value.T v)+ (Parameter (Value.T a))+ (Value.T v) (Value.T v)+lowpassModifier = FirstOrder.lowpassModifier+highpassModifier = FirstOrder.highpassModifier++causalP ::+ (Ring.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,+ IsFirstClass v, IsSized v vs, IsConst v, IsArithmetic v) =>+ CausalP.T p+ (Parameter (Value a), Value v) (Result (Value v))+{-+in contrast to CausalP.fromModifier this allows for sharing+between lowpass and highpass channel+-}+causalP =+ CausalP.mapSimple (\(l,x) -> do+ h <- A.sub x l+ return (Result{FirstOrder.lowpass_ = l,+ FirstOrder.highpass_ = h}))+ <<< (lowpassCausalP &&& arr snd)++lowpassCausalP, highpassCausalP ::+ (Ring.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a,+ IsFirstClass v, IsSized v vs, IsConst v,+ IsArithmetic a) =>+ CausalP.T p+ (Parameter (Value a), Value v) (Value v)+lowpassCausalP = CausalP.fromModifier lowpassModifier+highpassCausalP = CausalP.fromModifier highpassModifier++lowpassCausalPackedP, highpassCausalPackedP, causalRecursivePackedP ::+ (Ring.C a,+ IsFirstClass a, IsConst a, IsSized a as,+ IsPowerOf2 n, -- IsSized (Vector n a) vas,+ IsArithmetic a, IsPrimitive a) =>+ CausalP.T p+ (Parameter (Value a), Value (Vector n a)) (Value (Vector n a))+highpassCausalPackedP =+ CausalP.mapSimple (uncurry A.sub) <<<+ (arr snd &&& lowpassCausalPackedP)+lowpassCausalPackedP =+ causalRecursivePackedP <<<+ (arr fst &&&+ CausalP.mapSimple+ (\(FirstOrder.Parameter k, x) ->+ A.mul x =<< SoV.replicate =<< A.sub (valueOf 1) k))++{-+x = [x0, x1, x2, x3]++filter k y1 x+ = [x0 + k*y1,+ x1 + k*x0 + k^2*y1,+ x2 + k*x1 + k^2*x0 + k^3*y1,+ x3 + k*x2 + k^2*x1 + k^3*x0 + k^4*y1,+ ... ]++f0x = insert 0 (k*y1) x+f1x = f0x + k * f0x->1+f2x = f1x + k^2 * f1x->2+-}+causalRecursivePackedP =+ CausalP.mapAccumSimple+ (\(FirstOrder.Parameter k, xk0) y1 -> do+ y1k <- A.mul k y1+ xk1 <- Vector.modify (valueOf 0) (A.add y1k) xk0+ let size = Vector.sizeInTuple xk0+ kv <- SoV.replicate k+ xk2 <-+ fmap fst $+ foldM+ (\(y,k0) d ->+ liftM2 (,)+ (A.add y =<<+ Vector.shiftUpMultiZero d =<<+ A.mul y k0)+ (A.mul k0 k0))+ (xk1,kv)+ (takeWhile (< size) $ iterate (2*) 1)+{- do replicate in the loop+ xk2 <-+ fmap fst $+ foldM+ (\(y,k0) d ->+ liftM2 (,)+ (A.add y =<<+ Vector.shiftUpMultiZero d =<<+ A.mul y =<<+ SoV.replicate k0)+ (A.mul k0 k0))+ (xk1,k)+ (takeWhile (< size) $ iterate (2*) 1)+-}+ y0 <- Vector.extract (valueOf $ fromIntegral $ size - 1) xk2+ return (xk2, y0))+ (return (LLVM.value LLVM.zero))++{-+We can also optimize filtering with time-varying filter parameter.++k = [k0, k1, k2, k3]+x = [x0, x1, x2, x3]++filter k y1 x+ = [x0 + k0*y1,+ x1 + k1*x0 + k1*k0*y1,+ x2 + k2*x1 + k2*k1*x0 + k2*k1*k0*y1,+ x3 + k3*x2 + k3*k2*x1 + k3*k2*k1*x0 + k3*k2*k1*k0*y1,+ ... ]++f0x = insert 0 (k0*y1) x+f1x = f0x + k * f0x->1 k' = k * k->1+f2x = f1x + k' * f1x->2+++We can even interpret vectorised first order filtering+as first order filtering with matrix coefficients.++[x0 + k0*y1,+ x1 + k1*x0 + k1*k0*y1,+ x2 + k2*x1 + k2*k1*x0 + k2*k1*k0*y1,+ x3 + k3*x2 + k3*k2*x1 + k3*k2*k1*x0 + k3*k2*k1*k0*y1]+ =+ / 1 \ /x0\ / k0 0 0 0 \ /y1\+ | k1 1 | . |x1| + | k1*k0 0 0 0 | . |y2|+ | k2*k1 k2 1 | |x2| | k2*k1*k0 0 0 0 | |y3|+ \ k3*k2*k1 k3*k2 k3 1 / \x3/ \ k3*k2*k1*k0 0 0 0 / \y4/+++ / 1 \ / 1 \ / 1 \+ | k1 1 | = | 1 | . | k1 1 |+ | k2*k1 k2 1 | | k2*k1 1 | | k2 1 |+ \ k3*k2*k1 k3*k2 k3 1 / \ k3*k2 1 / \ k3 1 /+-}++++causalPackedP ::+ (Ring.C a, IsArithmetic a, IsPrimitive a,+ IsFirstClass a, IsConst a, IsSized a as,+ IsPowerOf2 n) =>+ CausalP.T p+ (Parameter (Value a), Value (Vector n a))+ (Result (Value (Vector n a)))+causalPackedP =+ CausalP.mapSimple (\(l,x) -> do+ h <- A.sub x l+ return (Result{FirstOrder.lowpass_ = l,+ FirstOrder.highpass_ = h}))+ <<< (lowpassCausalPackedP &&& arr snd)
+ src/Synthesizer/LLVM/Filter/Moog.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Synthesizer.LLVM.Filter.Moog+ (Parameter, parameter,+ causalP,+ ) where++import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1++import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder+import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog+import Synthesizer.Plain.Filter.Recursive (Pole(..))++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Simple.Value as Value++import Foreign.Storable (Storable, )++import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Vector as Vector++import qualified LLVM.Core as LLVM+import LLVM.Core+ (valueOf, Value, Struct,+ IsFirstClass, IsConst, IsArithmetic, IsFloating, IsSized,+ Undefined, undefTuple,+ CodeGenFunction, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import qualified Data.TypeLevel.Num as TypeNum+import Data.TypeLevel.Num (d0, d1, )++import qualified Control.Arrow as Arrow+import qualified Control.Applicative as App+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav+import Control.Arrow ((>>>), (&&&), arr, )+import Control.Applicative (liftA2, )++import qualified Algebra.Transcendental as Trans+-- import qualified Algebra.Field as Field+import qualified Algebra.Module as Module+import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric+import NumericPrelude.Base+++newtype Parameter n a = Parameter {getParam :: Moog.Parameter a}+ deriving (Functor, App.Applicative, Fold.Foldable, Trav.Traversable)+++instance (Phi a, TypeNum.Nat n) =>+ Phi (Parameter n a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable++instance (Undefined a, TypeNum.Nat n) =>+ Undefined (Parameter n a) where+ undefTuple = Class.undefTuplePointed++instance (Class.Zero a, TypeNum.Nat n) =>+ Class.Zero (Parameter n a) where+ zeroTuple = Class.zeroTuplePointed++parameterMemory ::+ (Rep.Memory a s, IsSized s ss, TypeNum.Nat n) =>+ Rep.MemoryRecord r (Struct (s, (s, ()))) (Parameter n a)+parameterMemory =+ liftA2 (\f k -> Parameter (Moog.Parameter f k))+ (Rep.memoryElement (Moog.feedback . getParam) d0)+ (Rep.memoryElement (Moog.lowpassParam . getParam) d1)++instance+ (Rep.Memory a s, IsSized s ss, TypeNum.Nat n) =>+ Rep.Memory (Parameter n a) (Struct (s, (s, ()))) where+ load = Rep.loadRecord parameterMemory+ store = Rep.storeRecord parameterMemory+ decompose = Rep.decomposeRecord parameterMemory+ compose = Rep.composeRecord parameterMemory+++instance (Value.Flatten ah al, TypeNum.Nat n) =>+ Value.Flatten (Parameter n ah) (Parameter n al) where+ flatten = Value.flattenTraversable+ unfold = Value.unfoldFunctor+++instance (Vector.ShuffleMatch m v, TypeNum.Nat n) =>+ Vector.ShuffleMatch m (Parameter n v) where+ shuffleMatch = Vector.shuffleMatchTraversable++instance (Vector.Access m a v, TypeNum.Nat n) =>+ Vector.Access m (Parameter n a) (Parameter n v) where+ insert = Vector.insertTraversable+ extract = Vector.extractTraversable+++parameter ::+ (Trans.C a, IsConst a, IsFloating a, TypeNum.Nat n) =>+ n -> Value a -> Value a ->+ CodeGenFunction r (Parameter n (Value a))+parameter order reson freq =+ Value.flatten $+ Parameter $ Moog.parameter (TypeNum.toInt order)+ (Pole (Value.constantValue reson) (Value.constantValue freq))++{-+infixr 1 ^>>, >>^++(>>^) ::+ (Value.Flatten b bl, Value.Flatten c cl) =>+ CausalP.T p al bl -> (b -> c) -> CausalP.T p al cl+(>>^) a f =+ a >>> CausalP.mapSimple (Value.flatten . f . Value.unfold)++(^>>) ::+ (Value.Flatten a al, Value.Flatten b bl) =>+ (a -> b) -> CausalP.T p bl cl -> CausalP.T p al cl+(^>>) f b =+ CausalP.mapSimple (Value.flatten . f . Value.unfold) >>> b+-}++merge ::+ (Module.C (Value.T a) (Value.T v),+ LLVM.MakeValueTuple v (Value v), IsConst v,+ LLVM.MakeValueTuple a (Value a), IsConst a) =>+ (Parameter n (Value a), Value v) -> Value v ->+ CodeGenFunction r (FirstOrder.Parameter (Value a), Value v)+merge (Parameter (Moog.Parameter f k), x) y0 =+ let c :: (LLVM.MakeValueTuple a (Value a)) => Value a -> Value.T a+ c = Value.constantValue+ in Value.flatten (fmap c k, c x - c f *> c y0)++amplify ::+ (Module.C (Value.T a) (Value.T v)) =>+ Parameter n (Value a) ->+ Value v ->+ CodeGenFunction r (Value v)+amplify (Parameter (Moog.Parameter f _k)) y1 =+ Value.decons $+ (1 + Value.constantValue f) *> Value.constantValue y1++causalP ::+ (Module.C (Value.T a) (Value.T v),+ Module.C a v, Storable v,+ LLVM.MakeValueTuple v (Value v),+ LLVM.MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,+ IsFirstClass v, IsSized v vs, IsConst v,+ TypeNum.Nat n) =>+ CausalP.T p+ (Parameter n (Value a), Value v) (Value v)+causalP =+ causalPSize undefined++causalPSize ::+ (Module.C (Value.T a) (Value.T v),+ Module.C a v, Storable v,+ LLVM.MakeValueTuple v (Value v),+ LLVM.MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,+ IsFirstClass v, IsSized v vs, IsConst v,+ TypeNum.Nat n) =>+ n ->+ CausalP.T p+ (Parameter n (Value a), Value v) (Value v)+causalPSize n =+ let order = TypeNum.toInt n+ feedZero = zero+ selectOutput = snd `asTypeOf` const (valueOf feedZero)+ in Arrow.arr fst &&&+ CausalP.feedbackControlled+ (return feedZero)+ (CausalP.mapSimple (uncurry merge) >>>+ CausalP.replicateControlled order Filt1.lowpassCausalP)+ (Arrow.arr selectOutput)+ >>> CausalP.mapSimple (uncurry amplify)
+ src/Synthesizer/LLVM/Filter/SecondOrder.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Synthesizer.LLVM.Filter.SecondOrder (+ Parameter, bandpassParameter,+ ParameterStruct, -- for cascade+ causalP, causalPackedP,+ ) where++import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2+import Synthesizer.Plain.Filter.Recursive.SecondOrder (Parameter(Parameter), )++import qualified Synthesizer.Plain.Modifier as Modifier++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector++import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Monad as M++import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, valueOf, Struct, Undefined, undefTuple,+ IsFirstClass, IsConst, IsArithmetic, IsFloating,+ Vector, IsPowerOf2, IsPrimitive, IsSized,+ CodeGenFunction, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import Data.TypeLevel.Num (d0, d1, d2, d3, d4, )+import qualified Data.TypeLevel.Num as TypeNum++import Control.Arrow (arr, (<<<), (&&&), )+import Control.Monad (liftM2, foldM, )+import Synthesizer.ApplicativeUtility (liftA4, liftA5, )++import qualified Algebra.Transcendental as Trans+-- import qualified Algebra.Field as Field+import qualified Algebra.Module as Module+import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric+import NumericPrelude.Base+++instance (Phi a) => Phi (Parameter a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable++instance Undefined a => Undefined (Parameter a) where+ undefTuple = Class.undefTuplePointed++instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where+ buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)++instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where+ tupleDesc = Class.tupleDescFoldable++instance LLVM.MakeValueTuple h l =>+ LLVM.MakeValueTuple (Parameter h) (Parameter l) where+ valueTupleOf = Class.valueTupleOfFunctor+++type ParameterStruct a = Struct (a, (a, (a, (a, (a, ())))))++parameterMemory ::+ (Rep.Memory a s, IsSized s ss) =>+ Rep.MemoryRecord r (ParameterStruct s) (Parameter a)+parameterMemory =+ liftA5 Parameter+ (Rep.memoryElement Filt2.c0 d0)+ (Rep.memoryElement Filt2.c1 d1)+ (Rep.memoryElement Filt2.c2 d2)+ (Rep.memoryElement Filt2.d1 d3)+ (Rep.memoryElement Filt2.d2 d4)++instance+ (Rep.Memory a s, IsSized s ss) =>+ Rep.Memory (Parameter a) (Struct (s, (s, (s, (s, (s, ())))))) where+ load = Rep.loadRecord parameterMemory+ store = Rep.storeRecord parameterMemory+ decompose = Rep.decomposeRecord parameterMemory+ compose = Rep.composeRecord parameterMemory+++instance (Value.Flatten ah al) =>+ Value.Flatten (Parameter ah) (Parameter al) where+ flatten = Value.flattenTraversable+ unfold = Value.unfoldFunctor++++instance (Phi a) => Phi (Filt2.State a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable++instance Undefined a => Undefined (Filt2.State a) where+ undefTuple = Class.undefTuplePointed++stateMemory ::+ (Rep.Memory a s, IsSized s ss) =>+ Rep.MemoryRecord r (Struct (s, (s, (s, (s, (s, ())))))) (Filt2.State a)+stateMemory =+ liftA4 Filt2.State+ (Rep.memoryElement Filt2.u1 d0)+ (Rep.memoryElement Filt2.u2 d1)+ (Rep.memoryElement Filt2.y1 d2)+ (Rep.memoryElement Filt2.y2 d3)+++instance+ (Rep.Memory a s, IsSized s ss) =>+ Rep.Memory (Filt2.State a) (Struct (s, (s, (s, (s, (s, ())))))) where+ load = Rep.loadRecord stateMemory+ store = Rep.storeRecord stateMemory+ decompose = Rep.decomposeRecord stateMemory+ compose = Rep.composeRecord stateMemory++instance (Value.Flatten ah al) =>+ Value.Flatten (Filt2.State ah) (Filt2.State al) where+ flatten = Value.flattenTraversable+ unfold = Value.unfoldFunctor+++{-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-}+bandpassParameter ::+ (Trans.C a, IsFloating a, IsConst a) =>+ Value a ->+ Value a ->+ CodeGenFunction r (Parameter (Value a))+bandpassParameter reson cutoff = do+ rreson <- A.fdiv (valueOf 1) reson+ k <- A.sub (valueOf 1) rreson+ k2 <- LLVM.neg =<< A.mul k k+ kcos <-+ A.mul (valueOf 2) =<< A.mul k =<<+ A.cos =<< A.mul cutoff =<<+ Value.decons Value.twoPi+ return $+ Filt2.Parameter+ rreson (valueOf zero) (valueOf zero)+ kcos k2++modifier ::+ (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) =>+ Modifier.Simple+ (Filt2.State (Value.T v))+ (Parameter (Value.T a))+ (Value.T v) (Value.T v)+modifier =+ Filt2.modifier++causalP ::+ (Ring.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a,+ IsFirstClass v, IsSized v vs, IsConst v,+ IsArithmetic a) =>+ CausalP.T p+ (Parameter (Value a), Value v) (Value v)+causalP =+ CausalP.fromModifier modifier+++{- |+Vector size must be at least D2.+-}+causalPackedP,+ causalRecursivePackedP ::+ (Ring.C a,+ IsFirstClass a, IsArithmetic a, IsConst a,+ IsPowerOf2 n, IsPrimitive a, IsSized a as,+ TypeNum.Mul n as vas, TypeNum.Pos vas) =>+-- IsPowerOf2 n, IsPrimitive a, IsSized (Vector n a) as) =>+ CausalP.T p+ (Parameter (Value a), Value (Vector n a)) (Value (Vector n a))+causalPackedP =+ causalRecursivePackedP <<<+ (arr fst &&& causalNonRecursivePackedP)++_causalRecursivePackedPAlt,+ causalNonRecursivePackedP ::+ (Ring.C a,+ IsFirstClass a, IsArithmetic a, IsConst a,+ IsPowerOf2 n, IsPrimitive a, IsSized a as) =>+ CausalP.T p+ (Parameter (Value a), Value (Vector n a)) (Value (Vector n a))+causalNonRecursivePackedP =+ CausalP.mapAccumSimple+ (\(p, v0) (x1,x2) -> do+ (_,v1) <- Vector.shiftUp x1 v0+ (_,v2) <- Vector.shiftUp x2 v1+ w0 <- A.mul v0 =<< SoV.replicate (Filt2.c0 p)+ w1 <- A.mul v1 =<< SoV.replicate (Filt2.c1 p)+ w2 <- A.mul v2 =<< SoV.replicate (Filt2.c2 p)+ y <- A.add w0 =<< A.add w1 w2+ let size = fromIntegral $ Vector.sizeInTuple v0+ u0 <- Vector.extract (valueOf $ size - 1) v0+ u1 <- Vector.extract (valueOf $ size - 2) v0+ return (y, (u0,u1)))+ (return (LLVM.value LLVM.zero, LLVM.value LLVM.zero))++{-+A filter of second order can be considered+as the convolution of two filters of first order.++[1,r]*[1,0,r^2] = [1,r,r^2,r^3]+[1,r,r^2,r^3] * [1,s,s^2,s^3]+ = [1,r]*[1,s]*[1,0,r^2]*[1,0,s^2]+ with+ a=r+s+ b=r*s+ = [1,a,b]*[1,0,r^2]*[1,0,s^2]+ = [1,a,b]*[1,0,a^2-2*b,0,b^2]++[1,0,0,0,r^4]*[1,0,0,0,s^4]+ = [1,0,0,0,(a^2-2*b)^2-2*b^2,0,0,0,b^4]+ = [1,0,0,0,a^4-4*a^2*b+2*b^2,0,0,0,b^4]+-}++{-+x = [x0, x1, x2, x3]++filter2 (a,-b) (y1,y2) x+ = [x0 + a*y1 - b*y2,+ x1 + a*x0 + (a^2-b)*y1 - a*b*y2,+ x2 + a*x1 + (a^2-b)*x0 + (a^3-2*a*b)*y1 + (-a^2*b+b^2)*y2,+ x3 + a*x2 + (a^2-b)*x1 + (a^3-2*a*b)*x0 + (a^4-3*a^2*b+b^2)*y1 + (-a^3*b+2*a*b^2)*y2]++(f0x = insert 0 (k*y1) x)+f1x = f0x + a * f0x->1 + b * f0x->2+f2x = f1x + (a^2-2*b) * f1x->2 + b^2 * f1x->4+-}+causalRecursivePackedP =+ CausalP.mapAccumSimple+ (\(p, x0) y1v -> do+ let size = Vector.sizeInTuple x0++ d1v <- SoV.replicate (Filt2.d1 p)+ d2v <- SoV.replicate (Filt2.d2 p)+ d2vn <- LLVM.neg d2v++ y1 <- Vector.extract (valueOf $ fromIntegral size - 1) y1v+ xk1 <-+ Vector.modify (valueOf 0)+ (\u0 -> A.add u0 =<< A.mul (Filt2.d1 p) y1) =<<+ A.add x0 =<< A.mul d2v =<<+ Vector.shiftDownMultiZero (size - 2) y1v++ -- let xk2 = xk1+ xk2 <-+ fmap fst $+ foldM+ (\(y,(a,b)) d ->+ liftM2 (,)+ (A.add y =<<+ M.liftR2 A.add+ {-+ Possibility for optimization:+ In the last step the second operand is a zero vector+ (LLVM already optimizes this away)+ and the first operand could be merged+ with the second operand of the previous step.+ -}+ (Vector.shiftUpMultiZero d =<< A.mul y a)+ (Vector.shiftUpMultiZero (2*d) =<< A.mul y b)) $+ liftM2 (,)+ (M.liftR2 A.sub+ (A.mul a a)+ (A.mul b (SoV.replicateOf 2)))+ (A.mul b b))+ (xk1,(d1v,d2vn))+ (takeWhile (< size) $ iterate (2*) 1)++ return (xk2, xk2))+ (return (LLVM.value LLVM.zero))++_causalRecursivePackedPAlt =+ CausalP.mapAccumSimple+ (\(p, x0) (x1,x2) -> do+ let size = Vector.sizeInTuple x0+ -- let xk1 = x0+ xk1 <-+ Vector.modify (valueOf 0)+ (\u0 ->+ A.add u0 =<<+ M.liftR2 A.add (A.mul (Filt2.d2 p) x2) (A.mul (Filt2.d1 p) x1)) =<<+ Vector.modify (valueOf 1)+ (\u1 -> A.add u1 =<< A.mul (Filt2.d2 p) x1)+ x0++ -- let xk2 = xk1+ d1v <- SoV.replicate (Filt2.d1 p)+ d2v <- SoV.replicate =<< LLVM.neg (Filt2.d2 p)+ xk2 <-+ fmap fst $+ foldM+ (\(y,(a,b)) d ->+ liftM2 (,)+ (A.add y =<<+ M.liftR2 A.add+ (Vector.shiftUpMultiZero d =<< A.mul y a)+ (Vector.shiftUpMultiZero (2*d) =<< A.mul y b)) $+ liftM2 (,)+ (M.liftR2 A.sub+ (A.mul a a)+ (A.mul b (SoV.replicateOf 2)))+ (A.mul b b))+ (xk1,(d1v,d2v))+ (takeWhile (< size) $ iterate (2*) 1)++ y0 <- Vector.extract (valueOf $ fromIntegral size - 1) xk2+ y1 <- Vector.extract (valueOf $ fromIntegral size - 2) xk2+ return (xk2, (y0,y1)))+ (return (LLVM.value LLVM.zero, LLVM.value LLVM.zero))++{-+A filter of second order can also be represented+by a filter of first order with 2x2-matrix coefficients.++filter1 ((d1,d2), (1,0)) (y1,y2) [(x0,0), (x1,0), (x2,0), (x3,0)]++/d1i d2i\ . /d1j d2j\ = /d1i*d1j + d2i d1i*d2j\+\ 1 0 / \ 1 0 / \ d1j d2j/+++With this representation we can also implement filters+with time-variant filter parameters+using time-variant first-order filter.+-}
+ src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Synthesizer.LLVM.Filter.SecondOrderCascade where++import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified LLVM.Extra.Representation as Rep+import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified LLVM.Extra.Class as Class++import qualified LLVM.Core as LLVM+import LLVM.Util.Loop (Phi, phis, addPhis, )+import LLVM.Core+ (Value, valueOf, Vector,+ IsPowerOf2, IsConst, IsArithmetic, IsPrimitive, IsFirstClass, IsSized,+ CodeGenFunction, )++import qualified Data.TypeLevel.Num as TypeNum+import qualified Data.TypeLevel.Num.Sets as TypeSet++import Data.Word (Word32, )++import qualified Control.Arrow as Arrow+import Control.Arrow ((>>>), (<<<), (&&&), arr, )++-- import qualified Algebra.Transcendental as Trans+-- import qualified Algebra.Field as Field+import qualified Algebra.Module as Module+import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric+import NumericPrelude.Base+++type Parameter n a = LLVM.Array n (Filt2.ParameterStruct a)++newtype ParameterValue n a =+ ParameterValue {parameterValue :: Value (Parameter n a)}+{-+Automatic deriving is not allowed even with GeneralizedNewtypeDeriving+because of IsSized constraint+and it would also be wrong for Functor and friends.+ deriving+ (Phi, LLVM.Undefined, Class.Zero,+ Functor, App.Applicative, Fold.Foldable, Trav.Traversable)+-}++instance (TypeNum.Nat n, IsSized a s) =>+ Phi (ParameterValue n a) where+ phis bb (ParameterValue r) =+ fmap ParameterValue $ phis bb r+ addPhis bb+ (ParameterValue r)+ (ParameterValue r') =+ addPhis bb r r'++instance (TypeNum.Nat n, IsSized a s) =>+ LLVM.Undefined (ParameterValue n a) where+ undefTuple = ParameterValue LLVM.undefTuple++instance (TypeNum.Nat n, IsSized a s) =>+ Class.Zero (ParameterValue n a) where+ zeroTuple = ParameterValue Class.zeroTuple++instance+ (TypeNum.Nat n, IsSized a s) =>+ Rep.Memory (ParameterValue n a) (Parameter n a) where+ load = Rep.loadNewtype ParameterValue+ store = Rep.storeNewtype (\(ParameterValue k) -> k)+ decompose = Rep.decomposeNewtype ParameterValue+ compose = Rep.composeNewtype (\(ParameterValue k) -> k)++++withSize ::+ (n -> CausalP.T p (ParameterValue n a, x) y) ->+ CausalP.T p (ParameterValue n a, x) y+withSize f = f undefined++fixSize ::+ n ->+ CausalP.T p (ParameterValue n a, x) y ->+ CausalP.T p (ParameterValue n a, x) y+fixSize _n = id++causalP ::+ (Ring.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a,+ IsFirstClass v, IsSized v vs, IsConst v,+ IsArithmetic a, TypeSet.Nat n,+ TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize) =>+ CausalP.T p (ParameterValue n a, Value v) (Value v)+causalP =+ withSize $ \n ->+ foldl (\x y -> (arr fst &&& x) >>> y) (arr snd) $+ map+ (\k ->+ Filt2.causalP <<<+ Arrow.first (CausalP.mapSimple+ (\ps -> getStageParameter ps k)))+ (take (TypeNum.toInt n) [0..])++causalPackedP ::+ (Ring.C a,+ IsPrimitive a, IsSized a as, IsConst a,+ IsArithmetic a, TypeSet.Nat n,+ TypeNum.Mul n LLVM.UnknownSize paramSize, TypeSet.Pos paramSize,+ IsPowerOf2 d, TypeNum.Mul d as vas, TypeSet.Pos vas) =>+ CausalP.T p+ (ParameterValue n a, Value (Vector d a)) (Value (Vector d a))+causalPackedP =+ withSize $ \n ->+ foldl (\x y -> (arr fst &&& x) >>> y) (arr snd) $+ map+ (\k ->+ Filt2.causalPackedP <<<+ Arrow.first (CausalP.mapSimple+ (\ps -> getStageParameter ps k)))+ (take (TypeNum.toInt n) [0..])++getStageParameter, getStageParameterMalloc, getStageParameterAlloca ::+ (IsFirstClass a, TypeSet.Nat n, IsSized a sa,+ TypeNum.Mul n LLVM.UnknownSize s, TypeSet.Pos s) =>+ ParameterValue n a ->+ Word32 ->+ CodeGenFunction r (Filt2Core.Parameter (Value a))+getStageParameter ps k =+ Rep.decompose =<<+ LLVM.extractvalue (parameterValue ps) k++{-+Expensive because we need a heap allocation for every sample.+However, we could allocate the memory once in the Causal initialization routine.+-}+getStageParameterMalloc ps k = do+ ptr <- LLVM.malloc+ LLVM.store (parameterValue ps) ptr+ p <- Rep.load =<< LLVM.getElementPtr0 ptr (valueOf k, ())+ LLVM.free ptr+ return p++{-+With this implementation, LLVM-2.6 generates a stack variable layout+that requires non-aligned access to vector values.+The result is a crash at runtime.+-}+getStageParameterAlloca ps k = do+ ptr <- LLVM.alloca+ LLVM.store (parameterValue ps) ptr+ Rep.load =<< LLVM.getElementPtr0 ptr (valueOf k, ())
+ src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module Synthesizer.LLVM.Filter.SecondOrderPacked (+ Parameter, bandpassParameter, State, causalP,+ ) where++import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2L+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Vector as Vector++import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, valueOf, Struct, Undefined, undefTuple,+ IsFirstClass, IsConst, IsFloating,+ Vector, IsPrimitive, IsSized,+ CodeGenFunction, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import Data.TypeLevel.Num (Add, D4, d0, d1, )+import qualified Data.TypeLevel.Num as TypeNum+import qualified Data.TypeLevel.Num.Sets as Sets++import Control.Applicative (liftA2, )++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field as Field+-- import qualified Algebra.Module as Module+-- import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- |+Layout:++> c0 [c1 d1 c2 d2]+-}+data Parameter a =+ Parameter (Value a) (Value (Vector D4 a))++instance (IsFirstClass a, IsPrimitive a) => Phi (Parameter a) where+ phis bb (Parameter r i) = do+ r' <- phis bb r+ i' <- phis bb i+ return (Parameter r' i')+ addPhis bb+ (Parameter r i)+ (Parameter r' i') = do+ addPhis bb r r'+ addPhis bb i i'++instance (IsFirstClass a, IsPrimitive a) => Undefined (Parameter a) where+ undefTuple = Parameter undefTuple undefTuple+++parameterMemory ::+ (IsPrimitive l, IsFirstClass l, IsSized l s,+ Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) =>+ Rep.MemoryRecord r (Struct (l, (Vector D4 l, ()))) (Parameter l)+parameterMemory =+ liftA2 Parameter+ (Rep.memoryElement (\(Parameter c0 _) -> c0) d0)+ (Rep.memoryElement (\(Parameter _ cd) -> cd) d1)++instance (IsPrimitive l, IsFirstClass l, IsSized l s,+ Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) =>+ Rep.Memory (Parameter l) (Struct (l, (Vector D4 l, ()))) where+ load = Rep.loadRecord parameterMemory+ store = Rep.storeRecord parameterMemory+ decompose = Rep.decomposeRecord parameterMemory+ compose = Rep.composeRecord parameterMemory+++type State = Vector D4+++{-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-}+bandpassParameter ::+ (Trans.C a, IsFloating a, IsConst a, IsPrimitive a) =>+ Value a ->+ Value a ->+ CodeGenFunction r (Parameter a)+bandpassParameter reson cutoff = do+ p <- Filt2L.bandpassParameter reson cutoff+ v <- Vector.assemble [Filt2.c1 p, Filt2.d1 p, Filt2.c2 p, Filt2.d2 p]+ return $ Parameter (Filt2.c0 p) v+++next ::+ (Vector.Arithmetic a) =>+ (Parameter a, Value a) ->+ Value (State a) ->+ CodeGenFunction r (Value a, Value (State a))+next (Parameter c0 k1, x0) y1 = do+ s0 <- A.mul c0 x0+ s1 <- Vector.dotProduct k1 y1+ y0 <- A.add s0 s1+ x1new <- Vector.extract (valueOf 0) y1+ y1new <- Vector.extract (valueOf 1) y1+ yv <- Vector.assemble [x0, y0, x1new, y1new]+ return (y0, yv)++causalP ::+ (Field.C a, Vector.Arithmetic a, IsSized (State a) as) =>+ CausalP.T p+ (Parameter a, Value a) (Value a)+causalP =+ CausalP.mapAccumSimple next+ (return (LLVM.value LLVM.zero))
+ src/Synthesizer/LLVM/Filter/Universal.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Synthesizer.LLVM.Filter.Universal (+ Result(Result, lowpass, highpass, bandpass, bandlimit),+ Parameter, parameter, causalP,+ ) where++import qualified Synthesizer.Plain.Filter.Recursive.Universal as Universal+import Synthesizer.Plain.Filter.Recursive.Universal+ (Parameter(Parameter),+ Result(Result, lowpass, highpass, bandpass, bandlimit))+import Synthesizer.Plain.Filter.Recursive (Pole(..))++import qualified Synthesizer.Plain.Modifier as Modifier++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Simple.Value as Value++import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Vector as Vector++import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, Struct,+ IsFirstClass, IsConst, IsArithmetic, IsFloating, IsSized,+ Undefined, undefTuple,+ CodeGenFunction, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import Data.TypeLevel.Num (d0, d1, d2, d3, d4, d5, )++import Synthesizer.ApplicativeUtility (liftA6, )++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field as Field+import qualified Algebra.Module as Module+-- import qualified Algebra.Ring as Ring+++instance (Phi a) => Phi (Parameter a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable++instance Undefined a => Undefined (Parameter a) where+ undefTuple = Class.undefTuplePointed++parameterMemory ::+ (Rep.Memory a s, IsSized s ss) =>+ Rep.MemoryRecord r (Struct (s, (s, (s, (s, (s, (s, ()))))))) (Parameter a)+parameterMemory =+ liftA6 Parameter+ (Rep.memoryElement Universal.k1 d0)+ (Rep.memoryElement Universal.k2 d1)+ (Rep.memoryElement Universal.ampIn d2)+ (Rep.memoryElement Universal.ampI1 d3)+ (Rep.memoryElement Universal.ampI2 d4)+ (Rep.memoryElement Universal.ampLimit d5)+++instance+ (Rep.Memory a s, IsSized s ss) =>+ Rep.Memory (Parameter a) (Struct (s, (s, (s, (s, (s, (s, ()))))))) where+ load = Rep.loadRecord parameterMemory+ store = Rep.storeRecord parameterMemory+ decompose = Rep.decomposeRecord parameterMemory+ compose = Rep.composeRecord parameterMemory+++instance LLVM.ValueTuple a => LLVM.ValueTuple (Result a) where+ buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)++instance LLVM.IsTuple a => LLVM.IsTuple (Result a) where+ tupleDesc = Class.tupleDescFoldable++instance (LLVM.MakeValueTuple ah al) =>+ LLVM.MakeValueTuple (Result ah) (Result al) where+ valueTupleOf = Class.valueTupleOfFunctor++instance (Value.Flatten ah al) =>+ Value.Flatten (Result ah) (Result al) where+ flatten = Value.flattenTraversable+ unfold = Value.unfoldFunctor+++instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where+ buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)++instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where+ tupleDesc = Class.tupleDescFoldable++instance (LLVM.MakeValueTuple ah al) =>+ LLVM.MakeValueTuple (Parameter ah) (Parameter al) where+ valueTupleOf = Class.valueTupleOfFunctor++instance (Value.Flatten ah al) =>+ Value.Flatten (Parameter ah) (Parameter al) where+ flatten = Value.flattenTraversable+ unfold = Value.unfoldFunctor+++instance (Vector.ShuffleMatch d v) =>+ Vector.ShuffleMatch d (Parameter v) where+ shuffleMatch = Vector.shuffleMatchTraversable++instance (Vector.Access d a v) =>+ Vector.Access d (Parameter a) (Parameter v) where+ insert = Vector.insertTraversable+ extract = Vector.extractTraversable+++instance (Phi a) => Phi (Result a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable++instance Undefined a => Undefined (Result a) where+ undefTuple = Class.undefTuplePointed++instance (Vector.ShuffleMatch d v) =>+ Vector.ShuffleMatch d (Result v) where+ shuffleMatch = Vector.shuffleMatchTraversable++instance (Vector.Access d a v) =>+ Vector.Access d (Result a) (Result v) where+ insert = Vector.insertTraversable+ extract = Vector.extractTraversable+++parameter ::+ (Trans.C a, IsConst a, IsFloating a) =>+ Value a -> Value a ->+ CodeGenFunction r (Parameter (Value a))+parameter reson freq =+ Value.flatten $+ Universal.parameter+ (Pole (Value.constantValue reson) (Value.constantValue freq))+-- (Pole (Value.unfold reson) (Value.unfold freq))+++modifier ::+ (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) =>+ Modifier.Simple+ (Universal.State (Value.T v))+ (Parameter (Value.T a))+ (Value.T v) (Result (Value.T v))+modifier =+ Universal.modifier++causalP ::+ (Field.C a, Module.C (Value.T a) (Value.T v),+ IsFirstClass a, IsSized a as, IsConst a,+ IsFirstClass v, IsSized v vs, IsConst v,+ IsArithmetic a) =>+ CausalP.T p+ (Parameter (Value a), Value v) (Result (Value v))+causalP =+ CausalP.fromModifier modifier
+ src/Synthesizer/LLVM/Frame/Stereo.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{- |+Re-export functions from "Sound.Frame.Stereo"+and add (orphan) instances for various LLVM type classes.+If you want to use the Stereo datatype with synthesizer-llvm+we recommend to import this module instead of+"Sound.Frame.Stereo" or "Sound.Frame.NumericPrelude.Stereo".+-}+module Synthesizer.LLVM.Frame.Stereo (+ Stereo.T, Stereo.cons, Stereo.left, Stereo.right,+ Stereo.arrowFromMono,+ Stereo.arrowFromMonoControlled,+ Stereo.arrowFromChannels,+ interleave,+ ) where++import qualified Synthesizer.Frame.Stereo as Stereo++import qualified LLVM.Extra.Class as Class+import qualified LLVM.Core as LLVM+import LLVM.Core+ (ValueTuple, buildTuple,+ Undefined, undefTuple,+ IsTuple, tupleDesc,+ MakeValueTuple, valueTupleOf,+ Struct, IsSized, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Vector as Vector+import Data.TypeLevel.Num (d0, d1, )++import Control.Monad (liftM2, )+import Control.Applicative (liftA2, )+import qualified Control.Applicative as App+++-- if it turns out to be useful, we may move it to sample-frame package+interleave :: (Stereo.T a, Stereo.T b) -> Stereo.T (a,b)+interleave (p,f) =+ Stereo.cons+ (Stereo.left p, Stereo.left f)+ (Stereo.right p, Stereo.right f)+++instance (Class.Zero a) => Class.Zero (Stereo.T a) where+ zeroTuple = Stereo.cons Class.zeroTuple Class.zeroTuple++instance ValueTuple a => ValueTuple (Stereo.T a) where+ buildTuple f =+ liftM2 Stereo.cons (buildTuple f) (buildTuple f)++instance (Undefined a) => Undefined (Stereo.T a) where+ undefTuple = Stereo.cons undefTuple undefTuple++instance (C.Select a) => C.Select (Stereo.T a) where+ select = C.selectTraversable++instance LLVM.CmpRet a b => LLVM.CmpRet (Stereo.T a) (Stereo.T b) where++instance MakeValueTuple h l =>+ MakeValueTuple (Stereo.T h) (Stereo.T l) where+ valueTupleOf s =+ Stereo.cons+ (LLVM.valueTupleOf $ Stereo.left s)+ (LLVM.valueTupleOf $ Stereo.right s)++instance IsTuple a => IsTuple (Stereo.T a) where+ tupleDesc s =+ tupleDesc (Stereo.left s) +++ tupleDesc (Stereo.right s)++instance (Phi a) => Phi (Stereo.T a) where+ phis bb v =+ liftM2 Stereo.cons+ (phis bb (Stereo.left v))+ (phis bb (Stereo.right v))+ addPhis bb x y = do+ addPhis bb (Stereo.left x) (Stereo.left y)+ addPhis bb (Stereo.right x) (Stereo.right y)+++instance (Vector.ShuffleMatch n v) => Vector.ShuffleMatch n (Stereo.T v) where+ shuffleMatch = Vector.shuffleMatchTraversable++instance (Vector.Access n a v) => Vector.Access n (Stereo.T a) (Stereo.T v) where+ insert = Vector.insertTraversable+ extract = Vector.extractTraversable+++memory ::+ (Rep.Memory l s, IsSized s ss) =>+ Rep.MemoryRecord r (Struct (s, (s, ()))) (Stereo.T l)+memory =+ liftA2 Stereo.cons+ (Rep.memoryElement Stereo.left d0)+ (Rep.memoryElement Stereo.right d1)++instance+ (Rep.Memory l s, IsSized s ss) =>+ Rep.Memory (Stereo.T l) (Struct (s, (s, ()))) where+ load = Rep.loadRecord memory+ store = Rep.storeRecord memory+ decompose = Rep.decomposeRecord memory+ compose = Rep.composeRecord memory+++{-+instance+ (Memory l s, IsSized s ss) =>+ Memory (Stereo.T l) (Struct (s, (s, ()))) where+ load ptr =+ liftM2 Stereo.cons+ (load =<< getElementPtr0 ptr (d0, ()))+ (load =<< getElementPtr0 ptr (d1, ()))+ store y ptr = do+ store (Stereo.left y) =<< getElementPtr0 ptr (d0, ())+ store (Stereo.right y) =<< getElementPtr0 ptr (d1, ())+-}
+ src/Synthesizer/LLVM/Generator/Exponential2.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+Exponential curve with controllable delay.+-}+module Synthesizer.LLVM.Generator.Exponential2 (+ Parameter,+ parameter,+ parameterPlain,+ causalP,++ ParameterPacked,+ parameterPacked,+ parameterPackedPlain,+ causalPackedP,+ ) where++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified Synthesizer.LLVM.Parameter as Param++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Representation as Rep++import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, valueOf, Vector,+ IsPowerOf2, IsConst, IsArithmetic, IsPrimitive, IsFirstClass, IsFloating, IsSized,+ Undefined, undefTuple,+ CodeGenFunction, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import qualified Data.TypeLevel.Num as TypeNum+import qualified Data.TypeLevel.Num.Sets as TypeSet++import Foreign.Storable (Storable, )++import qualified Control.Applicative as App+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav+import Control.Applicative (liftA2, (<*>), )+import Control.Arrow ((^<<), )++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric+import NumericPrelude.Base+++newtype Parameter a =+ Parameter a+++instance Functor Parameter where+ {-# INLINE fmap #-}+ fmap f (Parameter k) = Parameter (f k)++instance App.Applicative Parameter where+ {-# INLINE pure #-}+ pure x = Parameter x+ {-# INLINE (<*>) #-}+ Parameter f <*> Parameter k =+ Parameter (f k)++instance Fold.Foldable Parameter where+ {-# INLINE foldMap #-}+ foldMap = Trav.foldMapDefault++instance Trav.Traversable Parameter where+ {-# INLINE sequenceA #-}+ sequenceA (Parameter k) =+ fmap Parameter k+++instance (Phi a) => Phi (Parameter a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable++instance Undefined a => Undefined (Parameter a) where+ undefTuple = Class.undefTuplePointed++instance Class.Zero a => Class.Zero (Parameter a) where+ zeroTuple = Class.zeroTuplePointed++instance+ (Rep.Memory a s, IsSized s ss) =>+ Rep.Memory (Parameter a) s where+ load = Rep.loadNewtype Parameter+ store = Rep.storeNewtype (\(Parameter k) -> k)+ decompose = Rep.decomposeNewtype Parameter+ compose = Rep.composeNewtype (\(Parameter k) -> k)+++instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where+ buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)++instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where+ tupleDesc = Class.tupleDescFoldable++instance (LLVM.MakeValueTuple ah al) =>+ LLVM.MakeValueTuple (Parameter ah) (Parameter al) where+ valueTupleOf = Class.valueTupleOfFunctor+++instance (Value.Flatten ah al) =>+ Value.Flatten (Parameter ah) (Parameter al) where+ flatten = Value.flattenTraversable+ unfold = Value.unfoldFunctor+++instance (Vector.ShuffleMatch n v) =>+ Vector.ShuffleMatch n (Parameter v) where+ shuffleMatch = Vector.shuffleMatchTraversable++instance (Vector.Access n a v) =>+ Vector.Access n (Parameter a) (Parameter v) where+ insert = Vector.insertTraversable+ extract = Vector.extractTraversable+++parameter ::+ (Trans.C a, IsConst a, IsFloating a) =>+ Value a ->+ CodeGenFunction r (Parameter (Value a))+parameter halfLife =+ Value.flatten $ parameterPlain $+ Value.constantValue halfLife++parameterPlain ::+ (Trans.C a) =>+ a -> Parameter a+parameterPlain halfLife =+ Parameter $ 0.5 ** recip halfLife+++causalP ::+ (IsFirstClass a, IsSized a size,+ IsArithmetic a, IsConst a,+ Storable a, LLVM.MakeValueTuple a (Value a)) =>+ Param.T p a ->+ CausalP.T p (Parameter (Value a)) (Value a)+causalP initial =+ CausalP.mapAccum+ (\() (Parameter a) s -> do+ b <- A.mul a s+ return (s,b))+ return+ (return ())+ initial+++data ParameterPacked a =+ ParameterPacked {ppFeedback, ppCurrent :: a}+++instance Functor ParameterPacked where+ {-# INLINE fmap #-}+ fmap f p = ParameterPacked+ (f $ ppFeedback p) (f $ ppCurrent p)++instance App.Applicative ParameterPacked where+ {-# INLINE pure #-}+ pure x = ParameterPacked x x+ {-# INLINE (<*>) #-}+ f <*> p = ParameterPacked+ (ppFeedback f $ ppFeedback p)+ (ppCurrent f $ ppCurrent p)++instance Fold.Foldable ParameterPacked where+ {-# INLINE foldMap #-}+ foldMap = Trav.foldMapDefault++instance Trav.Traversable ParameterPacked where+ {-# INLINE sequenceA #-}+ sequenceA p =+ liftA2 ParameterPacked+ (ppFeedback p) (ppCurrent p)+++instance (Phi a) => Phi (ParameterPacked a) where+ phis = Class.phisTraversable+ addPhis = Class.addPhisFoldable++instance Undefined a => Undefined (ParameterPacked a) where+ undefTuple = Class.undefTuplePointed++instance Class.Zero a => Class.Zero (ParameterPacked a) where+ zeroTuple = Class.zeroTuplePointed+++memory ::+ (Rep.Memory l s, IsSized s ss) =>+ Rep.MemoryRecord r (LLVM.Struct (s, (s, ()))) (ParameterPacked l)+memory =+ liftA2 ParameterPacked+ (Rep.memoryElement ppFeedback TypeNum.d0)+ (Rep.memoryElement ppCurrent TypeNum.d1)++instance+ (Rep.Memory l s, IsSized s ss) =>+ Rep.Memory (ParameterPacked l) (LLVM.Struct (s, (s, ()))) where+ load = Rep.loadRecord memory+ store = Rep.storeRecord memory+ decompose = Rep.decomposeRecord memory+ compose = Rep.composeRecord memory+++instance LLVM.ValueTuple a => LLVM.ValueTuple (ParameterPacked a) where+ buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)++instance LLVM.IsTuple a => LLVM.IsTuple (ParameterPacked a) where+ tupleDesc = Class.tupleDescFoldable++instance (LLVM.MakeValueTuple ah al) =>+ LLVM.MakeValueTuple (ParameterPacked ah) (ParameterPacked al) where+ valueTupleOf = Class.valueTupleOfFunctor+++instance (Value.Flatten ah al) =>+ Value.Flatten (ParameterPacked ah) (ParameterPacked al) where+ flatten = Value.flattenTraversable+ unfold = Value.unfoldFunctor+++instance (Vector.ShuffleMatch m v) =>+ Vector.ShuffleMatch m (ParameterPacked v) where+ shuffleMatch = Vector.shuffleMatchTraversable++instance (Vector.Access m a v) =>+ Vector.Access m (ParameterPacked a) (ParameterPacked v) where+ insert = Vector.insertTraversable+ extract = Vector.extractTraversable++++withSize ::+ (n -> m (param (Value (Vector n a)))) ->+ m (param (Value (Vector n a)))+withSize f = f undefined++parameterPacked ::+ (Trans.C a, IsConst a, IsFloating a,+ IsPrimitive a, IsPowerOf2 n) =>+ Value a ->+ CodeGenFunction r (ParameterPacked (Value (Vector n a)))+parameterPacked halfLife = withSize $ \n -> do+ feedback <-+ SoV.replicate =<<+ A.pow (valueOf 0.5) =<<+ A.fdiv (valueOf $ fromIntegral $ TypeNum.toInt n) halfLife+ k <-+ A.pow (valueOf 0.5) =<<+ A.fdiv (valueOf 1) halfLife+ current <-+ Vector.iterate (A.mul k) (valueOf 1)+ return $ ParameterPacked feedback current+{-+ Value.flatten $ parameterPackedPlain $+ Value.constantValue halfLife+-}++withSizePlain ::+ (n -> param (Vector n a)) ->+ param (Vector n a)+withSizePlain f = f undefined++parameterPackedPlain ::+ (Trans.C a,+ IsPowerOf2 n) =>+ a -> ParameterPacked (Vector n a)+parameterPackedPlain halfLife =+ withSizePlain $ \n ->+ ParameterPacked+ (LLVM.vector [0.5 ** (fromIntegral (TypeNum.toInt n) / halfLife)])+ (LLVM.vector $ iterate (0.5 ** recip halfLife *) one)+++causalPackedP ::+ (IsFirstClass a, IsSized a size,+ IsArithmetic a, IsConst a,+ Storable a, LLVM.MakeValueTuple a (Value a),+ IsPrimitive a, IsPowerOf2 n,+ TypeNum.Mul n size pss, TypeNum.Pos pss) =>+ Param.T p a ->+ CausalP.T p (ParameterPacked (Value (Vector n a))) (Value (Vector n a))+causalPackedP initial =+ CausalP.mapAccum+ (\() p s0 -> do+ s1 <- A.mul (ppFeedback p) s0+ b <- A.mul (ppCurrent p) s0+ return (b,s1))+ return+ (return ())+ (LLVM.vector . (:[]) ^<< initial)
+ src/Synthesizer/LLVM/Parameter.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.LLVM.Parameter where++import qualified LLVM.Core as LLVM++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Algebraic as Algebraic+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import qualified Control.Category as Cat+import qualified Control.Arrow as Arr+import qualified Control.Applicative as App+import Control.Applicative (pure, liftA2, )++import Data.Tuple.HT (mapFst, )++import NumericPrelude.Numeric+import Prelude (fmap, error, (.), const, id, Functor, Monad, )+import qualified Prelude as P+++{- |+This data type is for parameters of parameterized signal generators and causal processes.+It is better than using plain functions of type @p -> a@+since it allows for numeric instances+and we can make explicit,+whether a parameter is constant.++We recommend to use parameters for atomic types.+Although a parameter of type @T p (a,b)@ is possible,+it means that the whole parameter is variable+if only one of the pair elements is variable.+This way you may miss optimizations.+-}+data T p a =+ Constant a |+ Variable (p -> a)+++get :: T p a -> (p -> a)+get (Constant a) = const a+get (Variable f) = f+++{- |+The call @value param v@ requires+that @v@ represents the same value as @valueTupleOf (get param p)@ for some @p@.+However @v@ might be the result of a load operation+and @param@ might be a constant.+In this case it is more efficient to use @valueTupleOf (get param undefined)@+since the constant is translated to an LLVM constant+that allows for certain optimizations.++This is the main function for taking advantage of a constant parameter+in low-level implementations.+For simplicity we do not omit constant parameters in the parameter struct+since this would mean to construct types at runtime and might become ugly.+Instead we just check using 'value' at the according places in LLVM code+whether a parameter is constant+and ignore the parameter from the struct in this case.+In many cases there will be no speed benefit+because the parameter will be loaded to a register anyway.+It can only lead to speed-up if subsequent optimizations+can precompute constant expressions.+Another example is 'drop' where a loop with constant loop count can be generated.+For small loop counts and simple loop bodies the loop might get unrolled.+-}+value ::+ LLVM.MakeValueTuple tuple value =>+ T p tuple -> value -> value+value (Constant a) _ = LLVM.valueTupleOf a+value (Variable _) v = v+++{- |+@.@ can be used for fetching a parameter from a super-parameter.+-}+instance Cat.Category T where+ id = Variable id+ Constant f . _ = Constant f+ Variable f . Constant a = Constant (f a)+ Variable f . Variable g = Variable (f . g)++{- |+@arr@ is useful for lifting parameter selectors to our parameter type+without relying on the constructor.+-}+instance Arr.Arrow T where+ arr = Variable+ first f = Variable (mapFst (get f))++++{- |+Useful for splitting @T p (a,b)@ into @T p a@ and @T p b@+using @fmap fst@ and @fmap snd@.+-}+instance Functor (T p) where+ fmap f (Constant a) = Constant (f a)+ fmap f (Variable g) = Variable (f . g)++{- |+Useful for combining @T p a@ and @T p b@ to @T p (a,b)@+using @liftA2 (,)@.+However, we do not recommend to do so+because the result parameter can only be constant+if both operands are constant.+-}+instance App.Applicative (T p) where+ pure a = Constant a+ Constant f <*> Constant a = Constant (f a)+ f <*> a = Variable (\p -> get f p (get a p))++instance Monad (T p) where+ return = pure+ Constant x >>= f = f x+ Variable x >>= f =+ Variable (\p -> get (f (x p)) p)+++instance Additive.C a => Additive.C (T p a) where+ zero = pure zero+ negate = fmap negate+ (+) = liftA2 (+)+ (-) = liftA2 (-)++instance Ring.C a => Ring.C (T p a) where+ one = pure one+ (*) = liftA2 (*)+ x^n = fmap (^n) x+ fromInteger = pure . fromInteger++instance Field.C a => Field.C (T p a) where+ (/) = liftA2 (/)+ recip = fmap recip+ fromRational' = pure . fromRational'++instance Algebraic.C a => Algebraic.C (T p a) where+ x ^/ r = fmap (^/ r) x+ sqrt = fmap sqrt+ root n = fmap (Algebraic.root n)++instance Trans.C a => Trans.C (T p a) where+ pi = pure pi+ exp = fmap exp+ log = fmap log+ logBase = liftA2 logBase+ (**) = liftA2 (**)+ sin = fmap sin+ tan = fmap tan+ cos = fmap cos+ asin = fmap asin+ atan = fmap atan+ acos = fmap acos+ sinh = fmap sinh+ tanh = fmap tanh+ cosh = fmap cosh+ asinh = fmap asinh+ atanh = fmap atanh+ acosh = fmap acosh+++{-+Instances for Haskell98 numeric type classes+that are useful when working together with other libraries on fixed types.+-}+instance P.Eq a => P.Eq (T p a) where+ (==) = error "Synthesizer.LLVM.Parameter: Num instance requires Eq but we cannot define that"++instance P.Show a => P.Show (T p a) where+ show _ = "Synthesizer.LLVM.Parameter"++instance P.Num a => P.Num (T p a) where+ (+) = liftA2 (P.+)+ (-) = liftA2 (P.-)+ (*) = liftA2 (P.*)+ negate = fmap P.negate+ abs = fmap P.abs+ signum = fmap P.signum+ fromInteger = pure . P.fromInteger++instance P.Fractional a => P.Fractional (T p a) where+ (/) = liftA2 (P./)+ fromRational = pure . P.fromRational
+ src/Synthesizer/LLVM/Parameterized/Signal.hs view
@@ -0,0 +1,819 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Synthesizer.LLVM.Parameterized.Signal (+ T(Cons), simple, map, mapSimple, iterate,+ module Synthesizer.LLVM.Parameterized.Signal+ ) where++import Synthesizer.LLVM.Parameterized.SignalPrivate+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as Causal+import qualified Synthesizer.LLVM.Parameter as Param++import qualified Synthesizer.LLVM.Random as Rnd+import qualified Synthesizer.LLVM.Wave as Wave+import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Execution as Exec+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.Representation as Rep+import LLVM.Extra.Control (whileLoop, ifThen, )++import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt+import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt+import qualified Data.StorableVector.Lazy.Pattern as SVP+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import qualified Data.StorableVector.Base as SVB++import qualified Synthesizer.LLVM.EventIterator as EventIt+import qualified Data.EventList.Relative.BodyTime as EventList+import qualified Numeric.NonNegative.Chunky as Chunky+import qualified Numeric.NonNegative.Wrapper as NonNeg++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.ScalarOrVector as SoV+import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )++import LLVM.Core as LLVM+import qualified LLVM.Util.Loop as Loop+import qualified Data.TypeLevel.Num as TypeNum++import Control.Monad (liftM2, liftM3, )+import Control.Arrow ((^<<), )+import Control.Applicative (liftA2, )++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealField as RealField+import qualified Algebra.Algebraic as Algebraic+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import Data.Word (Word32, )+import Foreign.Storable.Tuple ()+import Foreign.Storable (Storable, poke, )+import Foreign.Marshal.Array (advancePtr, )+import qualified Foreign.Marshal.Array as Array+import qualified Foreign.Marshal.Alloc as Alloc+import Foreign.ForeignPtr+ (unsafeForeignPtrToPtr, touchForeignPtr, withForeignPtr, )+import Foreign.Ptr (FunPtr, nullPtr, )+import Control.Exception (bracket, )+import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, )++import Data.Tuple.HT (swap, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )+++infixl 0 $#++($#) :: (Param.T p a -> b) -> (a -> b)+($#) f a = f (return a)+++mapAccum ::+ (Storable pnh, MakeValueTuple pnh pnl, Rep.Memory pnl pnp, IsSized pnp pns,+ Storable psh, MakeValueTuple psh psl, Rep.Memory psl psp, IsSized psp pss,+ Rep.Memory s struct, IsSized struct sa) =>+ (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 f startS selectParamF selectParamS+ (Cons next start createIOContext deleteIOContext) =+ Cons+ (\(parameterF, parameter) (sa0,ss0) -> do+ (a,sa1) <- next parameter sa0+ (b,ss1) <- Maybe.lift $ f (Param.value selectParamF parameterF) a ss0+ return (b, (sa1,ss1)))+ (\(parameterF, parameter) ->+ liftM2 (,) (start parameter) (startS (Param.value selectParamS parameterF)))+ (\p -> do+ (ioContext, (nextParam, startParam)) <- createIOContext p+ return (ioContext, ((Param.get selectParamF p, nextParam),+ (Param.get selectParamS p, startParam))))+ deleteIOContext+++zipWith ::+ (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) =>+ (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 createIOContextA deleteIOContextA)+ (Cons nextB startB createIOContextB deleteIOContextB) =+ Cons+ (\(parameterF, (parameterA, parameterB)) (sa0,sb0) -> do+ (a,sa1) <- nextA parameterA sa0+ (b,sb1) <- nextB parameterB sb0+ c <- Maybe.lift $ f (Param.value selectParamF parameterF) a b+ return (c, (sa1,sb1)))+ (\(parameterA, parameterB) ->+ liftM2 (,)+ (startA parameterA)+ (startB parameterB))+ (\p -> do+ (ca,(nextParamA,startParamA)) <- createIOContextA p+ (cb,(nextParamB,startParamB)) <- createIOContextB p+ return ((ca,cb),+ ((Param.get selectParamF p, (nextParamA, nextParamB)),+ (startParamA, startParamB))))+ (\(ca,cb) ->+ deleteIOContextA ca >>+ deleteIOContextB cb)++zipWithSimple ::+ (forall r. a -> b -> CodeGenFunction r c) ->+ T p a -> T p b -> T p c+zipWithSimple f =+ zipWith (const f) (return ())++zip :: T p a -> T p b -> T p (a,b)+zip = zipWithSimple (\a b -> return (a,b))+++-- * timeline edit++{- |+@tail empty@ generates the empty signal.+-}+tail ::+ T p a -> T p a+tail (Cons next start createIOContext deleteIOContext) = Cons+ next+ (\(nextParameter, startParameter) -> do+ s0 <- start startParameter+ Maybe.resolve (next nextParameter s0)+ (return s0)+ (\(_a,s1) -> return s1))+ (\p -> do+ (ioContext, (nextParam, startParam)) <- createIOContext p+ return (ioContext, (nextParam, (nextParam, startParam))))+ deleteIOContext++drop ::+ Param.T p Int ->+ T p a -> T p a+drop n (Cons next start createIOContext deleteIOContext) =+ let n32 = fmap (fromIntegral :: Int -> Word32) n in Cons+ next+ (\(nextParameter, i0, startParameter) -> do+ s0 <- start startParameter+ (_, _, s3) <-+ whileLoop (valueOf True, Param.value n32 i0, s0)+ (\(cont,i1,_s1) ->+ A.and cont =<<+ A.icmp IntUGT i1 (value LLVM.zero))+ (\(_cont,i1,s1) -> do+ (cont, s2) <-+ Maybe.resolve (next nextParameter s1)+ (return (valueOf False, s1))+ (\(_a,s) -> return (valueOf True, s))+ i2 <- A.dec i1+ return (cont, i2, s2))+ return s3)+ (\p -> do+ (ioContext, (nextParam, startParam)) <- createIOContext p+ return (ioContext, (nextParam,+ (nextParam, Param.get n32 p, startParam))))+ deleteIOContext++{- |+Appending many signals is inefficient,+since in cascadingly appended signals the parts are counted in an unary way.+Concatenating infinitely many signals is impossible.+If you want to concatenate a lot of signals,+please render them to lazy storable vectors first.+-}+{-+We might save a little space by using a union+for the states of the first and the second signal generator.+-}+append ::+ (Loop.Phi a) =>+ T p a -> T p a -> T p a+append+ (Cons nextA startA createIOContextA deleteIOContextA)+ (Cons nextB startB createIOContextB deleteIOContextB) =+ Cons+ (\(parameterA, parameterB) (firstPart,(sa0,sb0)) ->+ Maybe.fromBool $ do+ (contA, (a,sa1)) <-+ ifThen firstPart (valueOf False, (undefTuple,sa0))+ (Maybe.toBool $ nextA parameterA sa0)+ secondPart <- inv contA+ (contB, (b,sb1)) <-+ ifThen secondPart (valueOf True, (a,sb0))+ (Maybe.toBool $ nextB parameterB sb0)+ return (contB, (b, (contA, (sa1,sb1)))))+ (\(parameterA, parameterB) ->+ fmap ((,) (valueOf True)) $+ liftM2 (,)+ (startA parameterA)+ (startB parameterB))+ (\p -> do+ (ca,(nextParamA,startParamA)) <- createIOContextA p+ (cb,(nextParamB,startParamB)) <- createIOContextB p+ return ((ca,cb),+ ((nextParamA, nextParamB),+ (startParamA, startParamB))))+ (\(ca,cb) ->+ deleteIOContextA ca >>+ deleteIOContextB cb)+++-- * signal modifiers++{- |+Stretch signal in time by a certain factor.++This can be used for doing expensive computations+of filter parameters at a lower rate.+Alternatively, we could provide an adaptive @map@+that recomputes output values only if the input value changes,+or if the input value differs from the last processed one by a certain amount.+-}+interpolateConstant ::+ (Rep.Memory a struct, IsSized struct size,+ Ring.C b,+ IsFloating b, CmpRet b Bool,+ Storable b, MakeValueTuple b (Value b),+ IsConst b, IsFirstClass b, IsSized b sb) =>+ Param.T p b -> T p a -> T p a+interpolateConstant k+ (Cons next start createIOContext deleteIOContext) =+ Cons+ (\(kl,parameter) yState0 -> do+ ((y1,state1), ss1) <-+ Maybe.fromBool $+ whileLoop+ (valueOf True, yState0)+ (\(cont1, (_, ss1)) ->+ and cont1 =<< A.fcmp FPOLE ss1 (value LLVM.zero))+ (\(_,((_,state01), ss1)) ->+ Maybe.toBool $ liftM2 (,)+ (next parameter state01)+ (Maybe.lift $ A.add ss1 (Param.value k kl)))++ ss2 <- Maybe.lift $ A.sub ss1 (valueOf Ring.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, valueOf 0))+-}+ (fmap (\sa -> ((undefTuple, sa), value LLVM.zero)) . start)+ (\p -> do+ (ioContext, (nextParam, startParam)) <- createIOContext p+ return (ioContext, ((Param.get k p, nextParam), startParam)))+ deleteIOContext++++mix ::+ (IsArithmetic a) =>+ T p (Value a) -> T p (Value a) -> T p (Value a)+mix =+ zipWithSimple Sample.mixMono++mixStereo ::+ (IsArithmetic a) =>+ T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a))+mixStereo =+ zipWithSimple Sample.mixStereo+++envelope ::+ (IsArithmetic a) =>+ T p (Value a) -> T p (Value a) -> T p (Value a)+envelope =+ zipWithSimple Sample.amplifyMono++envelopeStereo ::+ (IsArithmetic a) =>+ T p (Value a) -> T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a))+envelopeStereo =+ zipWithSimple Sample.amplifyStereo++amplify ::+ (IsArithmetic a, Storable a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+ Param.T p a -> T p (Value a) -> T p (Value a)+amplify =+ map Sample.amplifyMono++amplifyStereo ::+ (IsArithmetic a, Storable a,+ MakeValueTuple a (Value a), IsFirstClass a, IsSized a size) =>+ Param.T p a -> T p (Stereo.T (Value a)) -> T p (Stereo.T (Value a))+amplifyStereo =+ map Sample.amplifyStereo+++-- * signal generators++constant ::+ (Storable a, MakeValueTuple a al,+ Rep.Memory al packed, IsSized packed s) =>+ Param.T p a -> T p al+constant x =+ simple+ (\pl () -> return (pl, ()))+ return+ x+ (return ())+++exponentialCore ::+ (Storable a, MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+ Param.T p a -> Param.T p a -> T p (Value a)+exponentialCore =+ iterate A.mul++exponential2 ::+ (Trans.C a, Storable a, MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+ Param.T p a -> Param.T p a -> T p (Value a)+exponential2 halfLife =+ exponentialCore (0.5 ** recip halfLife)+++exponentialBoundedCore ::+ (Storable a, MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a s, SoV.Real a, IsConst a) =>+ Param.T p a -> Param.T p a -> Param.T p a ->+ T p (Value a)+exponentialBoundedCore bound decay =+ iterate+ (\(b,k) y -> SoV.max b =<< A.mul k y)+ (liftA2 (,) bound decay)++{- |+Exponential curve that remains at the bound value+if it would fall below otherwise.+This way you can avoid extremal values, e.g. denormalized ones.+The initial value and the bound value must be positive.+-}+exponentialBounded2 ::+ (Trans.C a, Storable a, MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a s, SoV.Real a, IsConst a) =>+ Param.T p a -> Param.T p a -> Param.T p a ->+ T p (Value a)+exponentialBounded2 bound halfLife =+ exponentialBoundedCore bound (0.5 ** recip halfLife)+++osciCore ::+ (Storable t, MakeValueTuple t (Value t),+ IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t) =>+ Param.T p t -> Param.T p t -> T p (Value t)+osciCore phase freq =+ iterate SoV.incPhase freq phase++osci ::+ (Storable t, MakeValueTuple t (Value t),+ Storable c, MakeValueTuple c cl,+ IsFirstClass t, IsSized t size,+ Rep.Memory cl cp, IsSized cp cs,+ SoV.Fraction t, IsConst t) =>+ (forall r. cl -> Value t -> CodeGenFunction r y) ->+ Param.T p c ->+ Param.T p t -> Param.T p t -> T p y+osci wave waveParam phase freq =+ map wave waveParam $+ osciCore phase freq++osciSimple ::+ (Storable t, MakeValueTuple t (Value t),+ IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t) =>+ (forall r. Value t -> CodeGenFunction r y) ->+ Param.T p t -> Param.T p t -> T p y+osciSimple wave =+ osci (const wave) (return ())++osciSaw ::+ (Ring.C a0, IsConst a0, SoV.Replicate a0 a,+ Storable a, MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a size,+ SoV.Fraction a, IsPrimitive a, IsConst a) =>+ Param.T p a -> Param.T p a -> T p (Value a)+osciSaw =+ osciSimple Wave.saw++++rampCore ::+ (Storable a, MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+ Param.T p a -> Param.T p a -> T p (Value a)+rampCore = iterate A.add++parabolaCore ::+ (Storable a, MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+ Param.T p a -> Param.T p a -> Param.T p a -> T p (Value a)+parabolaCore d2 d1 start =+ Causal.apply (Causal.integrate start) $+ rampCore d2 d1++++rampInf, rampSlope,+ parabolaFadeInInf, parabolaFadeOutInf ::+ (Field.C a, Storable a, MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+ Param.T p a -> T p (Value a)+rampSlope slope = rampCore slope Additive.zero+rampInf dur = rampSlope (recip dur)++{-+t*(2-t) = 1 - (t-1)^2++(t+d)*(2-t-d) - t*(2-t)+ = d*(2-t) - d*t - d^2+ = 2*d*(1-t) - d^2+ = d*(2*(1-t) - d)++2*d*(1-t-d) + d^2 - (2*d*(1-t) + d^2)+ = -2*d^2+-}+parabolaFadeInInf dur =+ parabolaCore+ (fmap (\d -> -2*d*d) $ recip dur)+ (fmap (\d -> d*(2-d)) $ recip dur)+ Additive.zero++{-+1-t^2+-}+parabolaFadeOutInf dur =+ parabolaCore+ (fmap (\d -> -2*d*d) $ recip dur)+ (fmap (\d -> -d*d) $ recip dur)+ one++ramp,+ parabolaFadeIn, parabolaFadeOut,+ parabolaFadeInMap, parabolaFadeOutMap ::+ (RealField.C a, Storable a, MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+ Param.T p a -> T p (Value a)++ramp dur =+ Causal.apply (Causal.take (fmap round dur)) $+ rampInf dur++parabolaFadeIn dur =+ Causal.apply (Causal.take (fmap round dur)) $+ parabolaFadeInInf dur++parabolaFadeOut dur =+ Causal.apply (Causal.take (fmap round dur)) $+ parabolaFadeOutInf dur++parabolaFadeInMap dur =+ -- t*(2-t)+ Causal.apply (Causal.mapSimple (\t -> A.mul t =<< A.sub (valueOf 2) t)) $+ ramp dur++parabolaFadeOutMap dur =+ -- 1-t^2+ Causal.apply (Causal.mapSimple (\t -> A.sub (valueOf 1) =<< A.mul t t)) $+ ramp dur+++{- |+@noise seed rate@++The @rate@ parameter is for adjusting the amplitude+such that it is uniform across different sample rates+and after frequency filters.+The @rate@ is the ratio of the current sample rate to the default sample rate,+where the variance of the samples would be one.+If you want that at sample rate 22050 the variance is 1,+then in order to get a consistent volume at sample rate 44100+you have to set @rate = 2@.++I use the variance as quantity and not the amplitude,+because the amplitude makes only sense for uniformly distributed samples.+However, frequency filters transform the probabilistic density of the samples+towards the normal distribution according to the central limit theorem.+-}+noise ::+ (Algebraic.C a, IsFloating a, IsConst a,+ NumberOfElements TypeNum.D1 a,+ IsSized a ps, MakeValueTuple a (Value a), Storable a) =>+ Param.T p Word32 ->+ Param.T p a ->+ T p (Value a)+noise seed rate =+ let m2 = fromInteger $ div Rnd.modulus 2+ in map (\r y ->+ A.mul r+ =<< flip A.sub (valueOf $ m2+1)+ {-+ In principle it must be uitofp,+ but sitofp is a single instruction on x86+ and our numbers are below 2^31.+ -}+ =<< sitofp y)+ (sqrt (3 * rate) / return m2) $+ noiseCore seed++noiseCore, noiseCoreAlt ::+ Param.T p Word32 ->+ T p (Value Word32)+noiseCore seed =+ iterate (const Rnd.nextCG)+ (return ()) ((+1) . flip mod (Rnd.modulus-1) ^<< seed)++noiseCoreAlt seed =+ iterate (const Rnd.nextCG32)+ (return ()) ((+1) . flip mod (Rnd.modulus-1) ^<< seed)+++-- * conversion from and to storable vectors++fromStorableVector ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ Param.T p (SV.Vector a) ->+ T p value+fromStorableVector selectVec =+ Cons+ (\() (p0,l0) -> do+ cont <- Maybe.lift $ A.icmp IntUGT l0 (valueOf 0)+ Maybe.withBool cont $ do+ y1 <- Rep.load p0+ p1 <- advanceArrayElementPtr p0+ l1 <- A.dec l0+ return (y1,(p1,l1)))+ return+ (\p ->+ let (fp,s,l) = SVB.toForeignPtr $ Param.get selectVec p+ in return (fp,+ ((),+ (Rep.castStorablePtr $ unsafeForeignPtrToPtr fp `advancePtr` s,+ fromIntegral l :: Word32))))+ -- keep the foreign ptr alive+ touchForeignPtr++{-+This function calls back into the Haskell function 'ChunkIt.next'+that returns a pointer to the data of the next chunk+and advances to the next chunk in the sequence.+-}+fromStorableVectorLazy ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ Param.T p (SVL.Vector a) ->+ T p value+fromStorableVectorLazy sig =+ Cons+ (\(stable, lenPtr) (buffer0,length0) -> do+ (buffer1,length1) <- Maybe.lift $ do+ nextChunkFn <- staticFunction ChunkIt.nextCallBack+ needNext <- A.icmp IntEQ length0 (valueOf 0)+ ifThen needNext (buffer0,length0)+ (liftM2 (,)+ (call nextChunkFn stable lenPtr)+ (load lenPtr))+ valid <- Maybe.lift $ A.icmp IntNE buffer1 (valueOf nullPtr)+ Maybe.withBool valid $ do+ x <- Rep.load buffer1+ buffer2 <- advanceArrayElementPtr buffer1+ length2 <- A.dec length1+ return (x, (buffer2,length2)))+ (\() -> return (valueOf nullPtr, valueOf 0))+ (\p -> do+ s <- liftM2 (,) (ChunkIt.new (Param.get sig p)) Alloc.malloc+ return (s, (s,())))+ (\(stable,lenPtr) -> do+ ChunkIt.dispose stable+ Alloc.free lenPtr)+++piecewiseConstant ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct, IsSized struct size) =>+ Param.T p (EventList.T NonNeg.Int a) ->+ T p value+piecewiseConstant evs =+ Cons+ (\(stable, yPtr) (y0,length0) -> do+ (y1,length1) <- Maybe.lift $ do+ nextFn <- staticFunction EventIt.nextCallBack+ needNext <- A.icmp IntEQ length0 (valueOf 0)+ ifThen needNext (y0,length0)+ (fmap swap $+ liftM2 (,)+ (call nextFn stable yPtr)+ (Rep.load yPtr))+ Maybe.guard =<<+ Maybe.lift (A.icmp IntNE length1 (valueOf 0))+ length2 <- Maybe.lift (A.dec length1)+ return (y1, (y1,length2)))+ (\() -> return (undefTuple, valueOf 0))+ (\p -> do+ stable <- EventIt.new (Param.get evs p)+ yPtr <- Alloc.malloc+ return ((stable, asTypeOfEventListElement yPtr evs),+ ((stable, Rep.castStorablePtr yPtr), ())))+ (\(stable,yPtr) -> do+ EventIt.dispose stable+ Alloc.free yPtr)++asTypeOfEventListElement ::+ Ptr a ->+ Param.T p (EventList.T NonNeg.Int a) ->+ Ptr a+asTypeOfEventListElement ptr _ = ptr++++{- |+Turns a lazy chunky size into a signal generator with unit element type.+The signal length is the only information that the generator provides.+Using 'zipWith' you can use this signal as a lazy 'take'.+-}+lazySize ::+ Param.T p SVP.LazySize ->+ T p ()+lazySize size =+ Cons+ (\stable length0 -> do+ length1 <- Maybe.lift $ do+ nextFn <- staticFunction SizeIt.nextCallBack+ needNext <- A.icmp IntEQ length0 (valueOf 0)+ ifThen needNext length0+ (call nextFn stable)+ Maybe.guard =<<+ Maybe.lift (A.icmp IntNE length1 (valueOf 0))+ length2 <- Maybe.lift (A.dec length1)+ return ((), length2))+ (\() -> return (valueOf 0))+ (\p -> do+ stable <- SizeIt.new (Param.get size p)+ return (stable, (stable, ())))+ (\stable ->+ SizeIt.dispose stable)+++foreign import ccall safe "dynamic" derefFillPtr ::+ Exec.Importer (Ptr param -> Word32 -> Ptr a -> IO Word32)++run ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ T p value ->+ IO (Int -> p -> SV.Vector a)+run (Cons next start createIOContext deleteIOContext) =+ do -- this compiles once and is much faster than simpleFunction+ fill <-+ fmap derefFillPtr .+ Exec.compileModule .+ createFunction ExternalLinkage $+ \paramPtr size bPtr -> do+ (nextParam,startParam) <- Rep.load paramPtr+ s <- start startParam+ (pos,_) <- Maybe.arrayLoop size bPtr s $ \ ptri s0 -> do+ (y,s1) <- next nextParam s0+ Maybe.lift $ Rep.store y ptri+ return s1+ ret (pos :: Value Word32)++ return $ \len p ->+ unsafePerformIO $+ bracket (createIOContext p) (deleteIOContext . fst) $+ \ (_,params) ->+ SVB.createAndTrim len $ \ ptr ->+ Alloc.alloca $ \paramPtr ->+ poke paramPtr params >>+ (fmap fromIntegral $+ fill (Rep.castStorablePtr paramPtr)+ (fromIntegral len) (Rep.castStorablePtr ptr))++{- |+This is not really a function, see 'renderChunky'.+-}+render ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ T p value -> Int -> p -> SV.Vector a+render gen = unsafePerformIO $ run gen+++foreign import ccall safe "dynamic" derefChunkPtr ::+ Exec.Importer (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)+++compileChunky ::+ (Rep.Memory value struct,+ Rep.Memory state stateStruct,+ IsSized stateStruct stateSize,+ Rep.Memory startParamValue startParamStruct,+ Rep.Memory nextParamValue nextParamStruct,+ IsSized startParamStruct startParamSize,+ IsSized nextParamStruct nextParamSize) =>+ (forall r.+ nextParamValue ->+ state -> Maybe.T r (Value Bool, state) (value, state)) ->+ (forall r.+ startParamValue ->+ CodeGenFunction r state) ->+ IO (FunPtr (Ptr startParamStruct -> IO (Ptr stateStruct)),+ FunPtr (Ptr stateStruct -> IO ()),+ FunPtr (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32))+compileChunky next start =+ Exec.compileModule $+ liftM3 (,,)+ (createFunction ExternalLinkage $+ \paramPtr -> do+ -- danger: size computation in LLVM currently does not work for structs!+ pptr <- Rep.malloc+ flip Rep.store pptr =<< start =<< Rep.load paramPtr+ ret pptr)+ (createFunction ExternalLinkage $+ \ pptr -> Rep.free pptr >> ret ())+ (createFunction ExternalLinkage $+ \ paramPtr sptr loopLen ptr -> do+ param <- Rep.load paramPtr+ sInit <- Rep.load sptr+ (pos,sExit) <- Maybe.arrayLoop loopLen ptr sInit $ \ ptri s0 -> do+ (y,s1) <- next param s0+ Maybe.lift $ Rep.store y ptri+ return s1+ Rep.store sExit sptr+ ret (pos :: Value Word32))+++{- |+Renders a signal generator to a chunky storable vector with given pattern.+If the pattern is shorter than the generated signal+this means that the signal is shortened.+-}+runChunkyPattern ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ T p value ->+ IO (SVP.LazySize -> p -> SVL.Vector a)+runChunkyPattern (Cons next start createIOContext deleteIOContext) = do+ (startFunc, stopFunc, fill) <- compileChunky next start+ return $+ \ lazysize p -> SVL.fromChunks $ unsafePerformIO $ do+ (ioContext, (nextParam, startParam)) <- createIOContext p++ statePtr <- Rep.newForeignPtrParam stopFunc startFunc startParam+ nextParamPtr <- Rep.newForeignPtr (deleteIOContext ioContext) nextParam++ let go cs =+ unsafeInterleaveIO $+ case cs of+ [] -> return []+ SVL.ChunkSize size : rest -> do+ v <-+ withForeignPtr statePtr $ \sptr ->+ Rep.withForeignPtr nextParamPtr $ \nptr ->+ SVB.createAndTrim size $+ fmap fromIntegral .+ derefChunkPtr fill nptr sptr (fromIntegral size) .+ Rep.castStorablePtr+ (if SV.length v > 0+ then fmap (v:)+ else id) $+ (if SV.length v < size+ then return []+ else go rest)+ go (Chunky.toChunks lazysize)++runChunky ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ T p value ->+ IO (SVL.ChunkSize -> p -> SVL.Vector a)+runChunky sig =+ flip fmap (runChunkyPattern sig) $ \f size p ->+ f (Chunky.fromChunks (repeat size)) p++{- |+This looks like a function,+but it is not a function since it depends on LLVM being initialized+with LLVM.initializeNativeTarget before.+It is also problematic since you cannot control when and how often+the underlying LLVM code is compiled.+The compilation cannot be observed, thus it is referential transparent.+But this influences performance considerably+and I assume that you use this package exclusively for performance reasons.+-}+renderChunky ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ SVL.ChunkSize -> T p value ->+ p -> SVL.Vector a+renderChunky size gen =+ unsafePerformIO (runChunky gen) size
+ src/Synthesizer/LLVM/Parameterized/SignalPacked.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{- |+Signal generators that generate the signal in chunks+that can be processed natively by the processor.+Some of the functions for plain signals can be re-used without modification.+E.g. rendering a signal and reading from and to signals work+because the vector type as element type warrents correct alignment.+We can convert between atomic and chunked signals.++The article+<http://perilsofparallel.blogspot.com/2008/09/larrabee-vs-nvidia-mimd-vs-simd.html>+explains the difference between Vector and SIMD computing.+According to that the SSE extensions in Intel processors+must be called Vector computing.+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++import Synthesizer.LLVM.Parameterized.Signal (T(Cons), )+import qualified Synthesizer.LLVM.Parameterized.Signal as Sig+import qualified Synthesizer.LLVM.Parameter as Param++import qualified Synthesizer.LLVM.Random as Rnd+import qualified LLVM.Extra.Representation as Rep+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 LLVM.Extra.Control (whileLoop, )++import qualified Data.TypeLevel.Num as TypeNum++import qualified LLVM.Extra.Class as Class+import qualified LLVM.Extra.Arithmetic as A++import LLVM.Core as LLVM++-- we can also use <$> for parameters+import Control.Arrow ((^<<), )+import Control.Applicative (liftA2, )++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Algebraic as Algebraic+import qualified Algebra.RealField as RealField+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring++import Data.Word (Word32, )+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, packIndex ::+ (Vector.Access n a v) =>+ T p a -> T p v+pack = packRotate++packRotate (Cons next start createIOContext deleteIOContext) = Cons+ (\param s -> do+ (v2,_,s2) <-+ Maybe.fromBool $+ U.whileLoop+ (valueOf True,+ let v = undefTuple+ in (v, valueOf $ (fromIntegral $ Vector.sizeInTuple v :: Word32), s))+ (\(cont,(_v0,i0,_s0)) ->+ A.and cont =<<+ A.icmp IntUGT i0 (value LLVM.zero))+ (\(_,(v0,i0,s0)) -> Maybe.toBool $ do+ (a,s1) <- next param s0+ Maybe.lift $ do+ v1 <- fmap snd $ Vector.shiftDown a v0+ i1 <- A.dec i0+ return (v1,i1,s1))+ return (v2, s2))+ start+ createIOContext+ deleteIOContext++packIndex (Cons next start createIOContext deleteIOContext) = Cons+ (\param s -> do+ (v2,_,s2) <-+ Maybe.fromBool $+ U.whileLoop+ (valueOf True, (undefTuple, value LLVM.zero, s))+ (\(cont,(v0,i0,_s0)) ->+ A.and cont =<<+ A.icmp IntULT i0+ (valueOf $ fromIntegral $ Vector.sizeInTuple 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 ::+ (Vector.Access n a v, Class.Zero v) =>+ T p a -> T p v+packSmall (Cons next start createIOContext deleteIOContext) = Cons+ (\param s ->+ let vundef = undefTuple+ in foldr+ (\i rest (v0,s0) -> do+ (a,s1) <- next param s0+ v1 <- Maybe.lift $ Vector.insert (valueOf i) a v0+ rest (v1,s1))+ return+ (take (Vector.sizeInTuple vundef) [0..])+ (vundef, s))+ start+ createIOContext+ deleteIOContext+++unpack, unpackRotate, unpackIndex ::+ (Vector.Access n a v, Rep.Memory v vp, IsSized vp vs) =>+ T p v -> T p a+unpack = unpackRotate++unpackRotate (Cons next start createIOContext deleteIOContext) = Cons+ (\param (i0,v0,s0) -> do+ endOfVector <-+ Maybe.lift $ A.icmp IntEQ i0 (valueOf 0)+ (i2,v2,s2) <-+ Maybe.fromBool $+ U.ifThen endOfVector (valueOf True, (i0,v0,s0)) $ do+ (cont1, (v1,s1)) <- Maybe.toBool $ next param s0+ return (cont1, (valueOf $ fromIntegral $ Vector.sizeInTuple v0, v1, s1))+ Maybe.lift $ do+ a <- Vector.extract (valueOf 0 `asTypeOf` i0) v2+ v3 <- Vector.rotateDown v2+ i3 <- A.dec i2+ return (a, (i3,v3,s2)))+ (\p -> do+ s <- start p+ return (valueOf 0, undefTuple, s))+ createIOContext+ deleteIOContext++unpackIndex (Cons next start createIOContext deleteIOContext) = Cons+ (\param (i0,v0,s0) -> do+ endOfVector <-+ Maybe.lift $ A.icmp IntUGE i0+ (valueOf $ fromIntegral $ Vector.sizeInTuple 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, (value LLVM.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 $ Vector.sizeInTuple v, v, s))+ createIOContext+ deleteIOContext+++withSize ::+ (n -> T p (Value (Vector n a))) ->+ T p (Value (Vector n a))+withSize f = f undefined+++constant ::+ (Storable a, MakeValueTuple a (Value a),+ IsConst a, IsPrimitive a,+ IsPowerOf2 n, IsSized (Vector n a) s) =>+-- IsPowerOf2 n, IsSized a s, TypeNum.Pos vs, TypeNum.Mul n s vs) =>+ Param.T p a -> T p (Value (Vector n a))+constant x =+ Sig.constant (LLVM.vector . (:[]) ^<< x)+++exponential2 ::+ (Trans.C a, Storable a, MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a s, IsSized (Vector n a) vs,+ IsPrimitive a, IsArithmetic a, IsConst a,+ IsPowerOf2 n) =>+ Param.T p a -> Param.T p a -> T p (Value (Vector n a))+exponential2 halfLife start = withSize $ \n ->+ Sig.exponentialCore+ (LLVM.vector . (:[]) ^<<+ 0.5 ** (fromIntegral (TypeNum.toInt n) / halfLife))+ (liftA2+ (\h -> LLVM.vector . List.iterate (0.5 ** recip h *))+ halfLife start)++exponentialBounded2 ::+ (Trans.C a, Storable a, MakeValueTuple a (Value a),+ IsFirstClass a, IsSized a s, IsSized (Vector n a) vs,+ IsPrimitive a, Vector.Real a, IsConst a,+ IsPowerOf2 n) =>+ Param.T p a -> Param.T p a -> Param.T p a ->+ T p (Value (Vector n a))+exponentialBounded2 bound halfLife start = withSize $ \n ->+ Sig.exponentialBoundedCore+ (fmap (LLVM.vector . (:[])) bound)+ (LLVM.vector . (:[]) ^<<+ 0.5 ** (fromIntegral (TypeNum.toInt n) / halfLife))+ (liftA2+ (\h -> LLVM.vector . List.iterate (0.5 ** recip h *))+ halfLife start)+++osciCore ::+ (Storable t, MakeValueTuple t (Value t),+ IsFirstClass t, IsSized t size, IsSized (Vector n t) vsize,+ Vector.Real t, IsFloating t, RealField.C t, IsConst t,+ IsPowerOf2 n) =>+ Param.T p t -> Param.T p t -> T p (Value (Vector n t))+osciCore phase freq = withSize $ \n ->+ Sig.osciCore+ (liftA2+ (\f -> LLVM.vector . List.iterate (fraction . (f +)))+ freq phase)+ (fmap+ (\f -> LLVM.vector [fraction (fromIntegral (TypeNum.toInt n) * f)])+ freq)++osci ::+ (Storable t, MakeValueTuple t (Value t),+ Storable c, MakeValueTuple c cl,+ IsFirstClass t, IsSized t size, IsSized (Vector n t) vsize,+ Rep.Memory cl cp, IsSized cp cs,+ Vector.Real t, IsFloating t, RealField.C t, IsConst t,+ IsPowerOf2 n) =>+ (forall r. cl -> Value (Vector n t) -> CodeGenFunction r y) ->+ Param.T p c ->+ Param.T p t -> Param.T p t -> T p y+osci wave waveParam phase freq =+ Sig.map wave waveParam $+ osciCore phase freq++osciSimple ::+ (Storable t, MakeValueTuple t (Value t),+ IsFirstClass t, IsSized t size, IsSized (Vector n t) vsize,+ Vector.Real t, IsFloating t, RealField.C t, IsConst t,+ IsPowerOf2 n) =>+ (forall r. Value (Vector n t) -> CodeGenFunction r y) ->+ Param.T p t -> Param.T p t -> T p y+osciSimple wave =+ osci (const wave) (return ())+++rampInf, rampSlope,+ parabolaFadeInInf, parabolaFadeOutInf ::+ (RealField.C a, Storable a, MakeValueTuple a (Value a),+ IsPrimitive a, IsArithmetic a, IsConst a,+ IsPowerOf2 n, IsSized (Vector n a) s) =>+ Param.T p a -> T p (Value (Vector n a))+rampSlope slope = withSize $ \n ->+ Sig.rampCore+ (fmap (\s -> LLVM.vector [fromIntegral (TypeNum.toInt n) * s]) slope)+ (fmap (\s -> LLVM.vector (List.iterate (s +) 0)) slope)+rampInf dur = rampSlope (recip dur)++parabolaFadeInInf dur = withSize $ \ni ->+ let n = fromIntegral (TypeNum.toInt ni)+ in Sig.parabolaCore+ (fmap+ (\dr ->+ let d = n / dr+ in LLVM.vector [-2*d*d]) dur)+ (fmap+ (\dr ->+ let d = n / dr+ in LLVM.vector $ List.iterate (subtract $ 2 / dr ^ 2) (d*(2-d)))+ dur)+ (fmap+ (\dr ->+ LLVM.vector $ List.map (\t -> t*(2-t)) $ List.iterate (recip dr +) 0)+ dur)++parabolaFadeOutInf dur = withSize $ \ni ->+ let n = fromIntegral (TypeNum.toInt ni)+ in Sig.parabolaCore+ (fmap+ (\dr ->+ let d = n / dr+ in LLVM.vector [-2*d*d]) dur)+ (fmap+ (\dr ->+ let d = n / dr+ in LLVM.vector $ List.iterate (subtract $ 2 / dr ^ 2) (-d*d))+ dur)+ (fmap+ (\dr ->+ LLVM.vector $ List.map (\t -> 1-t*t) $ List.iterate (recip dr +) 0)+ dur)+++{- |+For the mysterious rate parameter see 'Sig.noise'.+-}+noise ::+ (Algebraic.C a, IsFloating a, IsConst a, IsPrimitive a,+ IsPowerOf2 n, IsSized (Vector n Word32) s,+ IsSized a as, TypeNum.Mul n as vas, TypeNum.Pos vas,+ MakeValueTuple a (Value a), Storable a) =>+ Param.T p Word32 ->+ Param.T p a ->+ T p (Value (Vector n a))+noise seed rate =+ let m2 = fromInteger $ div Rnd.modulus 2+ in Sig.map (\r y ->+ A.mul r+ =<< flip A.sub (SoV.replicateOf $ m2+1)+ {-+ In principle it must be uitofp,+ but sitofp is a single instruction on x86+ and our numbers are below 2^31.+ -}+ =<< sitofp y)+ (LLVM.vector . (:[]) ^<< sqrt (3 * rate) / return m2) $+ noiseCore seed++noiseCore, noiseCoreAlt ::+ (IsPowerOf2 n, IsSized (Vector n Word32) s) =>+ Param.T p Word32 ->+ T p (Value (Vector n Word32))+noiseCore seed =+ Sig.iterate (const Rnd.nextVector)+ (return ())+ (Rnd.vectorSeed . (+1) . flip mod (Rnd.modulus-1) ^<< seed)++noiseCoreAlt seed =+ Sig.iterate (const Rnd.nextVector64)+ (return ())+ (Rnd.vectorSeed . (+1) . flip mod (Rnd.modulus-1) ^<< seed)
+ src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Parameterized.SignalPrivate where++import qualified Synthesizer.LLVM.Parameter as Param+import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.Representation as Rep++import LLVM.Core (MakeValueTuple, IsSized, CodeGenFunction, )+import LLVM.Util.Loop (Phi, )++import Control.Arrow ((&&&), )++import Foreign.Storable (Storable, )++import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )+++{-+In this attempt we use a Haskell value as parameter supply.+This is okay, since the Haskell value will be converted to internal parameters+and then to LLVM values only once.+We can even have a storable vector as parameter.+However, this way we cannot easily implement+the Vanilla signal using Parameterized.Value as element type.++This separation is nice for maximum efficiency,+but it cannot be utilized by Generic.Signal methods.+Consider an expression like @iterate ((0.5 ** recip halfLife) *) 1@.+How shall we know, that the sub-expression @(0.5 ** recip halfLife)@+needs to be computated only once?+I do not try to do such optimization, instead I let LLVM do it.+However, this means that parameter initialization+will be performed (unnecessarily) at the beginning of every chunk.+For Generic.Signal method instances+we will always set the @(p -> paramTuple)@ to 'id'.++Could we drop parameterized signals at all+and rely entirely on Causal processes?+Unfortunately 'interpolateConstant' does not fit into the Causal process scheme.+(... although it would be causal for stretching factor being at least one.+It would have to maintain the waiting signal as state,+i.e. the state would grow linearly with time.)+Consider a signal algorithm, where the LFO frequency is a parameter.+-}+data T p a =+ forall state packed size ioContext+ startParamTuple startParamValue startParamPacked startParamSize+ nextParamTuple nextParamValue nextParamPacked nextParamSize.+ (Storable startParamTuple,+ Storable nextParamTuple,+ MakeValueTuple startParamTuple startParamValue,+ MakeValueTuple nextParamTuple nextParamValue,+ Rep.Memory startParamValue startParamPacked,+ Rep.Memory nextParamValue nextParamPacked,+ IsSized startParamPacked startParamSize,+ IsSized nextParamPacked nextParamSize,+ Rep.Memory state packed,+ IsSized packed size) =>+ Cons+ (forall r c.+ (Phi c) =>+ nextParamValue ->+ state -> Maybe.T r c (a, state))+ -- compute next value+ (forall r.+ startParamValue ->+ CodeGenFunction r state)+ -- initial state+ (p -> IO (ioContext, (nextParamTuple, startParamTuple)))+ {- initialization from IO monad+ This will be run within unsafePerformIO,+ so no observable In/Out actions please!+ -}+ (ioContext -> IO ())+ -- finalization from IO monad, also run within unsafePerformIO++simple ::+ (Storable startParamTuple,+ Storable nextParamTuple,+ MakeValueTuple startParamTuple startParamValue,+ MakeValueTuple nextParamTuple nextParamValue,+ Rep.Memory startParamValue startParamPacked,+ Rep.Memory nextParamValue nextParamPacked,+ IsSized startParamPacked startParamSize,+ IsSized nextParamPacked nextParamSize,+ Rep.Memory state packed,+ IsSized packed size) =>+ (forall r c.+ (Phi c) =>+ nextParamValue ->+ state -> Maybe.T r c (al, state)) ->+ (forall r.+ startParamValue ->+ CodeGenFunction r state) ->+ Param.T p nextParamTuple ->+ Param.T p startParamTuple -> T p al+simple f start selectParam initial = Cons+ (f . Param.value selectParam)+ (start . Param.value initial)+ (return . (,) () . Param.get (selectParam &&& initial))+ (const $ return ())+++map ::+ (Storable ph, MakeValueTuple ph pl, Rep.Memory pl pp, IsSized pp ps) =>+ (forall r. pl -> a -> CodeGenFunction r b) ->+ Param.T p ph ->+ T p a -> T p b+map f selectParamF+ (Cons next start createIOContext deleteIOContext) =+ Cons+ (\(parameterF, parameter) sa0 -> do+ (a,sa1) <- next parameter sa0+ b <- Maybe.lift $ f (Param.value selectParamF parameterF) a+ return (b, sa1))+ start+ (\p -> do+ (ioContext, (nextParam, startParam)) <- createIOContext p+ return (ioContext, ((Param.get selectParamF p, nextParam), startParam)))+ deleteIOContext++mapSimple ::+ (forall r. a -> CodeGenFunction r b) ->+ T p a -> T p b+mapSimple f = map (const f) (return ())+++instance Functor (T p) where+ fmap f = mapSimple (return . f)+++iterate ::+ (Storable ph, MakeValueTuple ph pl,+ Rep.Memory pl pp, IsSized pp ps,+ Storable a, MakeValueTuple a al,+ Rep.Memory al packed, IsSized packed s) =>+ (forall r. pl -> al -> CodeGenFunction r al) ->+ Param.T p ph ->+ Param.T p a -> T p al+iterate f selectParam initial = simple+ (\pl al0 ->+ Maybe.lift $ fmap (\al1 -> (al0,al1)) (f pl al0))+ return+ selectParam+ initial
+ src/Synthesizer/LLVM/Parameterized/Value.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Synthesizer.LLVM.Parameterized.Value where++import qualified Synthesizer.LLVM.Simple.Value as Value++import LLVM.Core hiding (zero, )+import LLVM.Util.Arithmetic (TValue, )+import qualified LLVM.Util.Arithmetic as Arith++{-+import qualified Synthesizer.Basic.Phase as Phase+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import Control.Monad (liftM2, liftM3, )+-}++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Algebraic as Algebraic+-- import qualified Algebra.RealRing as RealRing+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (map, zipWith, writeFile, )+++newtype T p a = Cons {decons :: forall r. p -> TValue r a}++instance (Additive.C a, IsArithmetic a, IsConst a) =>+ Additive.C (T p a) where+ zero = lift0 zero+ (+) = lift2 (+)+ (-) = lift2 (-)+ negate = lift1 negate++instance (Ring.C a, IsArithmetic a, IsConst a) =>+ Ring.C (T p a) where+ one = lift0 one+ (*) = lift2 (*)+ fromInteger = constant . fromInteger++instance (Ring.C a, IsArithmetic a, IsConst a) => Enum (T p a) where+ succ x = x + one+ pred x = x - one+ fromEnum _ = error "CodeGenFunction Value: fromEnum"+ toEnum = fromIntegral++{-+instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (T p a) where+ toRational _ = error "CodeGenFunction Value: toRational"++instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (T p a) where+ quot = binop (if (isSigned (undefined :: a)) then sdiv else udiv)+ rem = binop (if (isSigned (undefined :: a)) then srem else urem)+ quotRem x y = (quot x y, rem x y)+ toInteger _ = error "CodeGenFunction Value: toInteger"+-}++instance (Field.C a, IsConst a, IsFloating a) => Field.C (T p a) where+ (/) = lift2 (/)+ fromRational' = constant . fromRational'++{-+instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (T p a) where+ properFraction _ = error "CodeGenFunction Value: properFraction"+-}++instance (Algebraic.C a, IsConst a, IsFloating a) => Algebraic.C (T p a) where+ sqrt = lift1 sqrt++instance (Trans.C a, IsConst a, IsFloating a) => Trans.C (T p a) where+ pi = constant pi+ sin = lift1 sin+ cos = lift1 cos+ tan = lift1 tan++ asin = lift1 asin+ acos = lift1 acos+ atan = lift1 atan++ sinh = lift1 sinh+ cosh = lift1 cosh+ asinh = lift1 asinh+ acosh = lift1 acosh+ atanh = lift1 atanh++ (**) = lift2 (**)+ exp = lift1 exp+ log = lift1 log+++twoPi ::+ (Trans.C a, IsConst a, IsFloating a) =>+ T p a+twoPi = 2*pi+{-+twoPi ::+ (Cmp a b, P.Floating a, IsConst a, IsFloating a) =>+ TValue r a+twoPi = P.fromInteger 2 P.* P.pi+-}+++lift0 :: Value.T a -> T p a+lift0 x =+ Cons $ const $ Value.decons x++lift1 :: (Value.T a -> Value.T b) -> (T p a -> T p b)+lift1 f x =+ Cons (\p -> Value.decons $ f (Value.Cons $ decons x p))++lift2 :: (Value.T a -> Value.T b -> Value.T c) -> (T p a -> T p b -> T p c)+lift2 f x y =+ Cons $ \p -> Value.decons $+ f (Value.Cons $ decons x p) (Value.Cons $ decons y p)+++constantValue :: Value a -> T p a+constantValue x =+ Cons (const $ return x)++constant :: (IsConst a) => a -> T p a+constant = constantValue . valueOf++choose :: (IsConst a) => (p -> a) -> T p a+choose x =+ Cons (return . valueOf . x)
+ src/Synthesizer/LLVM/Random.hs view
@@ -0,0 +1,379 @@+{- |+Very simple random number generator according to Knuth+which should be fast and should suffice for generating just noise.+<http://www.softpanorama.org/Algorithms/random_generators.shtml>+-}+module Synthesizer.LLVM.Random where++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector++import qualified LLVM.Extra.Extension.X86 as X86+import qualified LLVM.Extra.Extension as Ext++import qualified LLVM.Extra.Arithmetic as A++import LLVM.Core as LLVM+import qualified Data.TypeLevel.Num as TypeNum++import Data.Function.HT (nest, )++import Data.Word (Word32, Word64, )+++factor :: Integral a => a+factor = 40692++modulus :: Integral a => a+modulus = 2147483399 -- 2^31-249++{-+We have to split the 32 bit integer in order to avoid overflow on multiplication.+'split' must be chosen, such that 'splitRem' is below 2^16.+-}+split :: Word32+split = succ $ div modulus factor++splitRem :: Word32+splitRem = split * factor - modulus+++{- |+efficient computation of @mod (s*factor) modulus@+without Integer or Word64, as in 'next64'.+-}+next :: Word32 -> Word32+next s =+ let (sHigh, sLow) = divMod s split+ in flip mod modulus $+ splitRem*sHigh + factor*sLow++next64 :: Word32 -> Word32+next64 s =+ fromIntegral $+ flip mod modulus $+ factor * (fromIntegral s :: Word64)++nextCG32 :: Value Word32 -> CodeGenFunction r (Value Word32)+nextCG32 s = do+ sHigh <- A.mul (valueOf splitRem) =<< udiv s split+ sLow <- A.mul (valueOf factor) =<< urem s split+ flip A.urem (valueOf modulus) =<< A.add sHigh sLow++nextCG64 :: Value Word32 -> CodeGenFunction r (Value Word32)+nextCG64 s =+ trunc =<<+ {-+ This is slow on x86 since the native @div@ is not used+ since LLVM wants to prevent overflow.+ We know that there cannot be an overflow,+ but I do not know how to tell LLVM.+ -}+ flip A.urem (valueOf (modulus :: Word64)) =<<+ A.mul (valueOf factor) =<<+ zext s++nextCG :: Value Word32 -> CodeGenFunction r (Value Word32)+nextCG s = do+ x <- A.mul (valueOf $ factor :: Value Word64) =<< zext s+ {-+ split 64 result between bit 30 and bit 31+ we cannot split above bit 31,+ since then 'low' can be up to 2^32-1+ and then later addition overflows.+ -}+ let p2e31 = 2^(31::Int)+ low <- A.and (valueOf $ p2e31-1) =<< trunc x+ high <- trunc =<< flip lshr (valueOf (31 :: Word64)) x+ -- fac = mod (2^31) modulus+ let fac = p2e31 - modulus+ {-+ fac < 250+ high < factor+ fac*high < factor*250+ low < 2^31+ low + fac*high+ < 2^31 + factor*250+ < 2*modulus+ Thus modulo by modulus needs at most one subtraction.+ -}+ prodMod <- A.add low =<< A.mul (valueOf fac) high+ prodModS <- A.sub prodMod (valueOf modulus)+ b <- A.icmp IntSLT prodModS (value zero)+ select b prodMod prodModS+++{-+How to vectorise?+E.g. by repeated distribution of modulus and split at bit 31.+Can we replace div by modulus by mul with (2^31+249) ?+-}+vectorParameter ::+ Integral a =>+ Int -> a+vectorParameter n =+ fromIntegral $ nest n next 1++vectorSeed ::+ (IsPowerOf2 n) =>+ Word32 -> Vector n Word32+vectorSeed seed =+ let n = Vector.size $ valueOf v+ v = vector $ take n $ iterate next seed+ in v++vector64 :: Value (Vector n Word64) -> Value (Vector n Word64)+vector64 = id++nextVector ::+ (IsPowerOf2 n) =>+ Value (Vector n Word32) ->+ CodeGenFunction r (Value (Vector n Word32))+nextVector s =+ Ext.run (nextVectorGeneric s) $+ Ext.with nextVector4X86 $ \nextChunk ->+ Vector.mapChunks (nextChunk (Vector.size s)) s++{- |+This needs only a third of the code of nextVectorGeneric for Vector D4+(37 instructions vs. 110 instructions)+because it arranges data more sensibly:+It de-interleaves the vector and truncates from 64 bit to 32 bit in-place.+-}+nextVector4X86 ::+ Ext.T+ (Int ->+ Value (Vector TypeNum.D4 Word32) ->+ 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++ mulAndReduce x = do+ (low0, high0) <-+ splitVector31to64 =<<+ muludq (prepConstFactor (vectorParameter n)) x++ splitVector31to64 =<<+ A.add low0 =<<+ muludq (prepConstFactor fac) =<<+ bitcast high0++ (lowEven, highEven) <-+ mulAndReduce =<<+ shufflevector s (value undef)+ (constVector [constOf 0, undef, constOf 2, undef])++ (lowOdd, highOdd) <-+ mulAndReduce =<<+ shufflevector s (value undef)+ (constVector [constOf 1, undef, constOf 3, undef])++ low <- truncAndInterleave2x64to4x32 lowEven lowOdd+ high <- truncAndInterleave2x64to4x32 highEven highOdd++ prodMod <-+ A.add low =<<+ -- more efficient for Word32 on x86 than LLVM-2.6's mul+ Vector.mul (SoV.replicateOf fac) high+ prodModS <- A.sub prodMod (SoV.replicateOf modulus)++ {-+ An element should become smaller by subtraction.+ If it becomes greater, then there was an overflow+ and 'min' chooses the value before subtraction.+ -}+ Vector.min prodModS prodMod++truncAndInterleave2x64to4x32 ::+ Value (Vector TypeNum.D2 Word64) ->+ Value (Vector TypeNum.D2 Word64) ->+ CodeGenFunction r (Value (Vector TypeNum.D4 Word32))+truncAndInterleave2x64to4x32 even2x64 odd2x64 = do+ even4x32 <- bitcast even2x64+ odd4x32 <- bitcast odd2x64+ LLVM.shufflevector even4x32 odd4x32+ (constVector [constOf 0, constOf 4, constOf 2, constOf 6])+++{-+This will access MMX registers.+-}+nextVector2X86 ::+ Ext.T+ (Int ->+ Value (Vector TypeNum.D2 Word32) ->+ 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)) =<<+ Vector.shuffle s+ (constVector [constOf 0, undef, constOf 1, undef])+ -- fac = mod (2^31) modulus+ let fac = 2^(31::Int) - modulus+ (low1, high1) <-+ splitVector31to64 =<<+ A.add low0 =<<+ muludq (prepConstFactor fac) =<<+ bitcast high0++ prodMod64 <-+ A.add low1 =<<+ muludq (prepConstFactor fac) =<<+ bitcast high1++-- prodMod <- Vector.map trunc prodMod64+-- prodModS <- A.sub prodMod (SoV.replicateOf modulus)+-- Vector.min prodModS prodMod++{-+ prodMod64as32 <- bitcast prodMod64+ prodMod <- Vector.shuffle+ (prodMod64as32 :: Value (Vector TypeNum.D4 Word32))+ (constVector $ map constOf [0,2])++ prodModS <- A.sub prodMod (SoV.replicateOf modulus)+-}++ prodMod <- bitcast prodMod64+ prodModS <- A.sub prodMod (prepConstFactor modulus)++ {-+ An element should become smaller by subtraction.+ If it becomes greater, then there was an overflow+ and 'min' chooses the value before subtraction.+ -}+ result <- Vector.min prodModS prodMod+ Vector.shuffle+ (result :: Value (Vector TypeNum.D4 Word32))+ (constVector $ map constOf [0,2])++splitVector31to64 ::+ (IsPowerOf2 n) =>+ Value (Vector n Word64) ->+ CodeGenFunction r (Value (Vector n Word64), Value (Vector n Word64))+splitVector31to64 x = do+ low <- A.and (SoV.replicateOf (2^(31::Int)-1)) x+ high <- flip lshr (SoV.replicateOf 31 `asTypeOf` x) x+ return (low, high)++{-+In case of a vector random generator the factor depends on the vector size+and thus we cannot do optimizations on a constant factor as in nextCG.+Thus we just compute the product @factor*seed@ as is+(this is of type @Word32 -> Word32 -> Word64@)+and try to compute @urem@ without using LLVM's @urem@+that calls __umoddi3 on every element.+Instead we optimize on the constant modulus+and utilize that is slightly smaller than 2^31.++We split the product:+ factor*seed = high0*2^31 + low0++Now it is+mod (factor*seed) modulus+ = mod (high0*2^31 + low0) modulus+ = mod (high0 * mod (2^31) modulus + low0) modulus+ = mod (high0 * 249 + low0) modulus++However, high0 * 249 + low0 is still too big,+it can be up to (excluding) 2^31 * 250.+Thus we repeat the split+high0 * 249 + low0 = high1 * 2^31 + low1++It is high1 < 250, and thus high1*249 < 62500,+high1 * 249 + low1 < 2*modulus.+With x = high1 * 249 + low1+we have+mod (factor*seed) modulus+ = if x<modulus+ then x+ else x-modulus+++An alternative approach would be to still multiply @let p = factor*seed@ exactly,+then do an approximate division @let q = approxdiv p modulus@,+then compute @p - q*modulus@ and+do a final adjustment in order to fix rounding errors.+The approximate division could be done by a floating point multiplication+or an integer multiplication with some shifting.+But in the end we will need at least the same number of multiplications+as in the approach that is implemented here.+-}+nextVectorGeneric ::+ (IsPowerOf2 n) =>+ Value (Vector n Word32) ->+ CodeGenFunction r (Value (Vector n Word32))+nextVectorGeneric s = do+ {-+ It seems that LLVM-2.6 on x86 does not make use of the fact,+ that the upper doublewords are zero.+ It seems to implement a full 64x64 multiplication in terms of pmuludq.+ -}+ (low0, high0) <-+ splitVector31 =<<+ Vector.umul32to64 (SoV.replicateOf (vectorParameter (Vector.size s))) s+ -- fac = mod (2^31) modulus+ let fac :: Integral a => a+ fac = 2^(31::Int) - modulus+ (low1, high1) <-+ splitVector31 =<<+ (\x -> A.add x =<< Vector.map zext low0) =<<+ Vector.umul32to64 (SoV.replicateOf fac) high0++ prodMod <-+ A.add low1 =<<+ Vector.mul (SoV.replicateOf fac) high1+ prodModS <- A.sub prodMod (SoV.replicateOf modulus)++ {-+ An element should become smaller by subtraction.+ If it becomes greater, then there was an overflow+ and 'min' chooses the value before subtraction.+ -}+ Vector.min prodModS prodMod+ -- alternatively (slower):+ -- selectNonNegativeGeneric prodModS prodMod++{- |+Select non-negative elements from the first vector,+otherwise select corresponding elements from the second vector.+-}+selectNonNegativeGeneric ::+ (IsPowerOf2 n) =>+ Value (Vector n Word32) ->+ Value (Vector n Word32) ->+ CodeGenFunction r (Value (Vector n Word32))+selectNonNegativeGeneric x y = do+ b <- A.icmp IntSGE x (value zero)+ Vector.select b x y+++splitVector31 ::+ (IsPowerOf2 n) =>+ Value (Vector n Word64) ->+ CodeGenFunction r (Value (Vector n Word32), Value (Vector n Word32))+splitVector31 x = do+ low <- A.and (SoV.replicateOf (2^(31::Int)-1)) =<< Vector.map trunc x+ high <- Vector.map trunc =<< flip lshr (SoV.replicateOf (31 :: Word64) `asTypeOf` x) x+ return (low, high)++{- |+This is the most obvious implementation+but unfortunately calls the expensive __umoddi3.+-}+nextVector64 ::+ (IsPowerOf2 n) =>+ Value (Vector n Word32) ->+ CodeGenFunction r (Value (Vector n Word32))+nextVector64 s =+ Vector.map trunc =<<+ flip A.urem (SoV.replicateOf modulus) =<<+ Vector.umul32to64 (SoV.replicateOf (vectorParameter (Vector.size s))) s
+ src/Synthesizer/LLVM/Sample.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.LLVM.Sample where++import qualified LLVM.Extra.Vector as Vector++import Foreign.Storable.Tuple ()++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, valueOf, value, undef,+ Vector, insertelement, extractelement,+ IsPrimitive, IsPowerOf2, IsArithmetic,+ CodeGenFunction, )+import Data.TypeLevel.Num (D2, D4, )++import Data.Word (Word32, )++import Control.Monad (liftM2, )++import NumericPrelude.Numeric hiding (zero, )+import NumericPrelude.Base+++{- |+Copy mono signal to both stereo channels.+-}+stereoFromMono ::+ Value a ->+ CodeGenFunction r (Stereo.T (Value a))+stereoFromMono x =+ return $ Stereo.cons x x++mixMonoFromStereo ::+ (IsArithmetic a) =>+ Stereo.T (Value a) ->+ CodeGenFunction r (Value a)+mixMonoFromStereo s =+ mixMono (Stereo.left s) (Stereo.right s)++zipStereo ::+ Value a -> Value a ->+ CodeGenFunction r (Stereo.T (Value a))+zipStereo l r =+ return (Stereo.cons l r)+++stereoFromVector ::+ (IsPrimitive a) =>+ Value (Vector D2 a) ->+ CodeGenFunction r (Stereo.T (Value a))+stereoFromVector x =+ liftM2 Stereo.cons+ (extractelement x (valueOf 0))+ (extractelement x (valueOf 1))++vectorFromStereo ::+ (IsPrimitive a) =>+ Stereo.T (Value a) ->+ CodeGenFunction r (Value (Vector D2 a))+vectorFromStereo s = do+ x <- insertelement (value undef) (Stereo.left s) (valueOf 0)+ insertelement x (Stereo.right s) (valueOf 1)+++quadroFromVector ::+ (IsPrimitive a) =>+ Value (Vector D4 a) ->+ CodeGenFunction r (Stereo.T (Stereo.T (Value a)))+quadroFromVector x =+ liftM2 Stereo.cons+ (liftM2 Stereo.cons+ (extractelement x (valueOf 0))+ (extractelement x (valueOf 1)))+ (liftM2 Stereo.cons+ (extractelement x (valueOf 2))+ (extractelement x (valueOf 3)))++vectorFromQuadro ::+ (IsPrimitive a) =>+ Stereo.T (Stereo.T (Value a)) ->+ CodeGenFunction r (Value (Vector D4 a))+vectorFromQuadro s = do+ let x0 = value undef+ sl = Stereo.left s+ sr = Stereo.right s+ x1 <- insertelement x0 (Stereo.left sl) (valueOf 0)+ x2 <- insertelement x1 (Stereo.right sl) (valueOf 1)+ x3 <- insertelement x2 (Stereo.left sr) (valueOf 2)+ insertelement x3 (Stereo.right sr) (valueOf 3)+++mixMono ::+ (IsArithmetic a) =>+ Value a -> Value a ->+ CodeGenFunction r (Value a)+mixMono = A.add++mixStereo ::+ (IsArithmetic a) =>+ Stereo.T (Value a) -> Stereo.T (Value a) ->+ CodeGenFunction r (Stereo.T (Value a))+mixStereo x y =+ liftM2 Stereo.cons+ (A.add (Stereo.left x) (Stereo.left y))+ (A.add (Stereo.right x) (Stereo.right y))+++class Additive a where+ zero :: a+ add :: a -> a -> CodeGenFunction r a++instance (IsArithmetic a) => Additive (Value a) where+ zero = LLVM.value LLVM.zero+ add = A.add++instance (Additive a) => Additive (Stereo.T a) where+ zero = Stereo.cons zero zero+ add x y =+ liftM2 Stereo.cons+ (add (Stereo.left x) (Stereo.left y))+ (add (Stereo.right x) (Stereo.right y))++++{- |+This may mean more shuffling and is not necessarily better than mixStereo.+-}+mixStereoV ::+ (IsArithmetic a, IsPrimitive a) =>+ Stereo.T (Value a) -> Stereo.T (Value a) ->+ CodeGenFunction r (Stereo.T (Value a))+mixStereoV x y =+ do xv <- vectorFromStereo x+ yv <- vectorFromStereo y+ stereoFromVector =<< A.add xv yv++mixVector ::+ (Vector.Arithmetic a, IsPowerOf2 n) =>+ Value (Vector n a) ->+ CodeGenFunction r (Value a)+mixVector = Vector.sum++mixVectorToStereo ::+ (Vector.Arithmetic a, IsPowerOf2 n) =>+ Value (Vector n a) ->+ CodeGenFunction r (Stereo.T (Value a))+mixVectorToStereo =+ fmap (uncurry Stereo.cons) .+ Vector.sumInterleavedToPair++{- |+Mix components with even index to the left channel+and components with odd index to the right channel.+-}+mixInterleavedVectorToStereo ::+ (Vector.Arithmetic a, IsPowerOf2 n) =>+ Value (Vector n a) ->+ CodeGenFunction r (Stereo.T (Value a))+mixInterleavedVectorToStereo =+ fmap (uncurry Stereo.cons) .+ Vector.sumInterleavedToPair+++amplifyMono ::+ (IsArithmetic a) =>+ Value a -> Value a ->+ CodeGenFunction r (Value a)+amplifyMono = A.mul++amplifyStereo ::+ (IsArithmetic a) =>+ Value a -> Stereo.T (Value a) ->+ CodeGenFunction r (Stereo.T (Value a))+amplifyStereo x y =+ liftM2 Stereo.cons+ (A.mul x (Stereo.left y))+ (A.mul x (Stereo.right y))++subsampleVector ::+ (Vector.Access n a v) =>+ v -> CodeGenFunction r a+subsampleVector =+ Vector.extract (LLVM.value LLVM.zero :: Value Word32)
+ src/Synthesizer/LLVM/Server.hs view
@@ -0,0 +1,57 @@+module Main where++import qualified Synthesizer.LLVM.Server.Packed.Test as ServerPackedTest+import qualified Synthesizer.LLVM.Server.Packed.Run as ServerPacked+import qualified Synthesizer.LLVM.Server.Scalar.Test as ServerScalarTest+import qualified Synthesizer.LLVM.Server.Scalar.Run as ServerScalar++import qualified LLVM.Core as LLVM++import Control.Monad (when, )+++part :: Int+part = 106++main :: IO ()+main =+ when (part<200)+ (putStrLn "run 'aconnect' to connect to the MIDI controller") >>+ LLVM.initializeNativeTarget >>+ case part of+ 000 -> ServerScalar.pitchBend+ 001 -> ServerScalar.frequencyModulation+ 002 -> ServerScalar.keyboard+ 003 -> ServerScalar.keyboardStereo+ 004 -> ServerScalar.keyboardMulti+ 005 -> ServerScalar.keyboardStereoMulti+ 100 -> ServerPacked.frequencyModulation+ 101 -> ServerPacked.keyboard+ 102 -> ServerPacked.keyboardStereo+ 103 -> ServerPacked.keyboardFM+ 104 -> ServerPacked.keyboardFMMulti+ 105 -> ServerPacked.keyboardDetuneFM+ 106 -> ServerPacked.keyboardFilter+ 200 -> ServerScalarTest.pitchBend0+ 201 -> ServerScalarTest.pitchBend1+ 202 -> ServerScalarTest.pitchBend2+ 203 -> ServerScalarTest.sequencePress+ 300 -> ServerPackedTest.adsr+ 301 -> ServerPackedTest.sequencePlain+ 302 -> ServerPackedTest.sequenceLLVM+ 303 -> ServerPackedTest.sequencePitchBendCycle+ 304 -> ServerPackedTest.sequencePitchBendSimple+ 305 -> ServerPackedTest.sequencePitchBend+ 306 -> ServerPackedTest.sequenceModulated+ 307 -> ServerPackedTest.sequencePress+ 308 -> ServerPackedTest.sequenceModulatedLong+ 309 -> ServerPackedTest.sequenceModulatedLongFM+ 310 -> ServerPackedTest.sequenceModulatedRepeat+ 311 -> ServerPackedTest.sequenceSample+ 312 -> ServerPackedTest.sequenceSample1 -- leak+-- 313 -> ServerPackedTest.testSequenceSample1a -- leak+ 320 -> ServerPackedTest.sequenceSample2 -- leak+ 321 -> ServerPackedTest.sequenceSample3 -- leak+ 322 -> ServerPackedTest.sequenceSample4 -- leak+ 323 -> ServerPackedTest.sequenceFM1 -- leak+ _ -> error "not implemented server part"
+ src/Synthesizer/LLVM/Server/Common.hs view
@@ -0,0 +1,153 @@+module Synthesizer.LLVM.Server.Common where++import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Sound.ALSA.Sequencer.Address as Addr+import qualified Sound.ALSA.Sequencer.Client as Client+import qualified Sound.ALSA.Sequencer.Port as Port+import qualified Sound.ALSA.Sequencer.Queue as Queue+import qualified Sound.ALSA.Sequencer.RealTime as RealTime+import qualified Sound.ALSA.Sequencer.Event as Event++import qualified Sound.ALSA.PCM as ALSA+import qualified Synthesizer.Storable.ALSA.Play as Play+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS++import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Parameter as Param++import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Core as LLVM++import qualified Data.EventList.Relative.BodyTime as EventListBT++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as SVL++import Foreign.Storable (Storable, )++import qualified Synthesizer.Generic.Signal as SigG++import qualified Sound.MIDI.Message.Channel as ChannelMsg++import qualified Sound.Sox.Frame as SoxFrame++import Control.Arrow ((^<<), )++import qualified Numeric.NonNegative.Wrapper as NonNegW++import qualified Algebra.RealRing as RealRing+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.Additive as Additive++import Data.Word (Word8, )++import NumericPrelude.Numeric (zero, round, )+import Prelude hiding (Real, round, break, )++++channel :: ChannelMsg.Channel+channel = ChannelMsg.toChannel 0++sampleRate :: Num a => a+-- sampleRate = 24000+-- sampleRate = 48000+sampleRate = 44100++latency :: Int+latency = 0+-- latency = 256+-- latency = 480++chunkSize :: SVL.ChunkSize+chunkSize = Play.defaultChunkSize+++lazySize :: SigG.LazySize+lazySize =+ let (SVL.ChunkSize size) = chunkSize+ in SigG.LazySize size++periodTime :: Field.C t => t+periodTime =+ let (SVL.ChunkSize size) = chunkSize+ in ToInteger.fromIntegral size Field./ Ring.fromInteger sampleRate+++type Real = Float+++($/) :: (Functor f) => f (a -> b) -> a -> f b+f $/ x = fmap ($x) f+++{-# INLINE play #-}+play ::+ (RealRing.C t, Additive.C y, ALSA.SampleFmt y) =>+ t -> t -> SigSt.T y -> IO ()+play period rate =+ Play.auto period (round rate) .+ SigSt.append (SigSt.replicate chunkSize latency zero)+-- FiltG.delayPosLazySize chunkSize latency+-- FiltG.delayPos latency++-- ToDo: do not record the empty chunk that is inserted for latency+{-# INLINE playAndRecord #-}+playAndRecord ::+ (RealRing.C t, Additive.C y, ALSA.SampleFmt y, SoxFrame.C y) =>+ FilePath -> t -> t -> SigSt.T y -> IO ()+playAndRecord fileName period rate =+ Play.autoAndRecord period fileName (round rate) .+ SigSt.append (SigSt.replicate chunkSize latency zero)+++piecewiseConstant ::+ (Storable a,+ LLVM.MakeValueTuple a al,+ Rep.Memory al am,+ LLVM.IsSized am as) =>+ Param.T p (PC.T a) -> SigP.T p al+piecewiseConstant pc =+ SigP.piecewiseConstant+ (EventListBT.mapTime+ (NonNegW.fromNumber . fromIntegral . NonNegW.toNumber) ^<< pc)+-- SigP.piecewiseConstant (PC.subdivideInt ^<< pc)++transposeModulation ::+ (Functor stream) =>+ Real ->+ stream (PC.BendModulation Real) ->+ stream (PC.BendModulation Real)+transposeModulation freq =+ fmap (PC.shiftBendModulation (freq/sampleRate))+++{-# INLINE amplitudeFromVelocity #-}+amplitudeFromVelocity :: Real -> Real+amplitudeFromVelocity vel = 4**vel+++-- cf. synthesizer-alsa:Synthesizer.Storable.ALSA.Server.Test+makeNote :: Event.NoteEv -> Word8 -> Event.T+makeNote typ pit =+ Event.Cons+ { Event.highPriority = False+ , Event.tag = 0+ , Event.queue = Queue.direct+ , Event.timestamp =+ Event.RealTime $ RealTime.fromInteger 0+ , Event.source = Addr.Cons {+ Addr.client = Client.subscribers,+ Addr.port = Port.unknown+ }+ , Event.dest = Addr.Cons {+ Addr.client = Client.subscribers,+ Addr.port = Port.unknown+ }+ , Event.body =+ Event.NoteEv typ+ (Event.simpleNote 0 pit 64)+ }
+ src/Synthesizer/LLVM/Server/Packed/Instrument.hs view
@@ -0,0 +1,1494 @@+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Server.Packed.Instrument where++import Synthesizer.LLVM.Server.Common++import qualified Synthesizer.EventList.ALSA.MIDI as Ev+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified Sound.Sox.Read as SoxRead+import qualified Sound.Sox.Option.Format as SoxOption++import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, )++import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL+import qualified Synthesizer.LLVM.Filter.Allpass as Allpass+import qualified Synthesizer.LLVM.Filter.Moog as MoogL+import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS+import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Wave as WaveL+import qualified Synthesizer.LLVM.Parameter as Param+import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), )+import Synthesizer.LLVM.Parameterized.Signal (($#), )++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Monad as LM+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Core as LLVM+import qualified Data.TypeLevel.Num as TypeNum++import Control.Arrow.Monad ((=<<<), listen, )+import qualified Data.HList as HL++import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SVP+import qualified Data.StorableVector.Lazy as SVL++import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter++import Control.Arrow ((<<<), (^<<), (<<^), (&&&), (***), arr, first, second, )+import Control.Applicative (liftA2, liftA3, )++import Data.Tuple.HT (mapPair, fst3, snd3, thd3, )++import Data.Int (Int32, )++{-+import qualified Numeric.NonNegative.Class as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+-}+import qualified Numeric.NonNegative.Chunky as NonNegChunky++import qualified Algebra.RealRing as RealRing+import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric (zero, round, (^?), )+import Prelude hiding (Real, round, break, )++++type Vector = LLVM.Vector VectorSize Real+type VectorSize = TypeNum.D4+++vectorSize :: Int+vectorSize = TypeNum.toInt (undefined :: VectorSize)++vectorChunkSize :: SVL.ChunkSize+vectorChunkSize =+ let (SVL.ChunkSize size) = chunkSize+ in SVL.ChunkSize (div size vectorSize)++vectorRate :: Fractional a => a+vectorRate = sampleRate / fromIntegral vectorSize+++frequencyFromBendModulation ::+{-+ (Storable a,+ LLVM.MakeValueTuple a (Value a)) =>+-}+ Param.T p Real ->+ Param.T p (PC.T (PC.BendModulation Real), Real) ->+ SigP.T p (LLVM.Value Vector)+frequencyFromBendModulation speed fmFreq =+ MIDIL.frequencyFromBendModulationPacked (speed/sampleRate)+ $* piecewiseConstant+ (fmap (\(fm,freq) -> transposeModulation freq fm) fmFreq)++stereoFrequenciesFromDetuneBendModulation ::+ Param.T p Real ->+ Param.T p (PC.T Real, PC.T (PC.BendModulation Real), Real) ->+ SigP.T p (Stereo.T (LLVM.Value Vector))+stereoFrequenciesFromDetuneBendModulation speed detFmFreq =+ (CausalP.envelopeStereo+ $< frequencyFromBendModulation speed+ (fmap (\(_det,fm,freq) -> (fm,freq)) detFmFreq))+ <<<+ CausalP.zipWithSimple Sample.zipStereo+ <<<+ CausalPS.raise 1 &&&+ (CausalPS.raise 1 <<< CausalP.mapSimple LLVM.neg)+ $* piecewiseConstantVector+ (fmap (\(det,_fm,_freq) -> det) detFmFreq)+++pingReleaseEnvelope ::+ IO (Real -> Real -> Real -> Ev.LazyTime -> SigSt.T Vector)+pingReleaseEnvelope =+ liftA2+ (\pressed release decay rel vel dur ->+ SigStL.continuePacked+ (pressed (chunkSizesFromLazyTime dur) (decay,vel))+ (\x -> release vectorChunkSize (rel,x)))+ (SigP.runChunkyPattern $+ let decay = arr fst+ velocity = arr snd+ in SigPS.exponential2 (decay*sampleRate)+ (amplitudeFromVelocity ^<< velocity))+ (SigP.runChunky $+ let release = arr fst+ amplitude = arr snd+ in (CausalP.take (round ^<< (release*5*vectorRate)) $*+ SigPS.exponential2 (release*sampleRate) amplitude))++pingRelease ::+ IO (Real -> Real -> Instrument Real Vector)+pingRelease =+ liftA2+ (\osc env dec rel vel freq dur ->+ osc freq (env dec rel vel dur))+ (CausalP.runStorableChunky+ (let freq = arr id+ in CausalP.envelope $>+ SigPS.osciSimple WaveL.saw zero (freq/sampleRate)))+ pingReleaseEnvelope++pingStereoRelease ::+ IO (Real -> Real -> Instrument Real (Stereo.T Vector))+pingStereoRelease =+ liftA2+ (\osc env dec rel vel freq dur ->+ osc freq (env dec rel vel dur))+ (CausalP.runStorableChunky+ (let freq = arr id+ in CausalP.envelopeStereo $>+ SigP.zipWithSimple Sample.zipStereo+ (SigPS.osciSimple WaveL.saw zero+ (0.999*freq/sampleRate))+ (SigPS.osciSimple WaveL.saw zero+ (1.001*freq/sampleRate))))+ pingReleaseEnvelope++pingStereoReleaseFM ::+ IO (Real -> Real ->+ PC.T Real ->+ PC.T Real ->+ Real -> Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+pingStereoReleaseFM =+ liftA2+ (\osc env dec rel detune shape phase phaseDecay fm vel freq dur ->+ osc+ ((phase, phaseDecay), shape, (detune,fm,freq))+ (env dec rel vel dur))+ (CausalP.runStorableChunky+ (let phs = arr (fst.fst3)+ dec = arr (snd.fst3)+ shp = arr snd3+ fm = arr thd3+ in CausalP.envelopeStereo $>+ ((CausalP.stereoFromMonoControlled+ (CausalPS.shapeModOsci WaveL.rationalApproxSine1)+ $< piecewiseConstantVector shp)+ <<^ Stereo.interleave+ $< (CausalP.zipWithSimple Sample.zipStereo+ <<<+ arr id &&& CausalP.mapSimple LLVM.neg+ $* SigPS.exponential2 (dec*sampleRate) phs)+ $* stereoFrequenciesFromDetuneBendModulation 10 fm)))+ pingReleaseEnvelope++{- |+Square like wave constructed as difference+of two phase shifted sawtooth like oscillations.+-}+squareStereoReleaseFM ::+ IO (Real -> Real ->+ PC.T Real ->+ PC.T Real ->+ PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+squareStereoReleaseFM =+ liftA2+ (\osc env dec rel detune shape phase fm vel freq dur ->+ osc+ ((phase, shape), (detune,fm,freq))+ (env dec rel vel dur))+ (CausalP.runStorableChunky+ (let phs = arr (fst.fst)+ shp = arr (snd.fst)+ fm = arr snd+ chanOsci =+ CausalP.mix+ <<<+ (CausalPS.shapeModOsci WaveL.rationalApproxSine1+ <<<+ second (first (CausalP.mapSimple LLVM.neg)))+ &&&+ (CausalP.mapSimple LLVM.neg+ <<<+ CausalPS.shapeModOsci WaveL.rationalApproxSine1)+ <<^+ (\((p,s),f) -> (s,(p,f)))+ in CausalP.envelopeStereo $>+ ((CausalP.stereoFromMonoControlled chanOsci+ $< SigP.zip+ (piecewiseConstantVector phs)+ (piecewiseConstantVector shp))+ $* stereoFrequenciesFromDetuneBendModulation 10 fm)))+ pingReleaseEnvelope++bellStereoFM ::+ IO (Real -> Real ->+ PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+bellStereoFM =+ liftA2+ (\osc env dec rel detune fm vel freq dur ->+ osc ((detune, fm, freq), vel,+ (env (dec/4) rel vel dur,+ env (dec/7) rel vel dur))+ (env dec rel vel dur))+ (CausalP.runStorableChunky+ (let fm = arr fst3+ vel = arr snd3+ env4 = arr (fst.thd3)+ env7 = arr (snd.thd3)+ mix x y = CausalP.mixStereo <<< x&&&y+ osci sel v d =+ CausalP.envelopeStereo+ <<<+ (arr sel ***+ (CausalPS.amplifyStereo v+ <<<+ CausalP.stereoFromMono+ (CausalPS.osciSimple WaveL.approxSine4+ $< SigPS.constant zero)+ <<<+ CausalPS.amplifyStereo d))+ in (osci fst3 0.6 1 `mix`+ osci snd3 (0.02 * 50^?vel) 4 `mix`+ osci thd3 (0.02 * 100^?vel) 7)+ <<<+ CausalP.feedSnd (stereoFrequenciesFromDetuneBendModulation 5 fm)+ <<<+ arr (\(e1,(e4,e7)) -> (e1,e4,e7))+ $> {-+ Be careful, those storable vectors shorten the whole sound+ if they have shorter release than the main envelope.+ -}+ SigP.zip+ (SigP.fromStorableVectorLazy env4)+ (SigP.fromStorableVectorLazy env7)))+ pingReleaseEnvelope++bellNoiseStereoFM ::+ IO (Real -> Real ->+ PC.T Real -> PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+bellNoiseStereoFM =+ liftA2+ (\osc env dec rel noiseAmp noiseReson fm vel freq dur ->+ osc ((fm, freq),+ (noiseAmp,noiseReson),+ (vel,+ env (dec/4) rel vel dur,+ env (dec/7) rel vel dur))+ (env dec rel vel dur))+ (CausalP.runStorableChunky+ (let fm = arr fst3+ noiseAmp = arr (fst.snd3)+ noiseReson = arr (snd.snd3)+ vel = arr (fst3.thd3)+ env4 = arr (snd3.thd3)+ env7 = arr (thd3.thd3)+ mix x y = CausalP.mix <<< x&&&y+ osci sel v d =+ CausalP.envelope+ <<<+ (arr sel ***+ (CausalPS.amplify v+ <<<+ (CausalPS.osciSimple WaveL.approxSine4+ $< SigPS.constant zero)+ <<<+ CausalPS.amplify d))+ noise sel d =+ (CausalP.envelope $<+ piecewiseConstantVector noiseAmp)+ <<<+ CausalP.envelope+ <<<+ (arr sel ***+ ({- UniFilter.lowpass+ ^<< -}+ (CtrlPS.process+ $> SigPS.noise 12 (sampleRate/20000))+ <<<+-- CausalP.zipWithSimple UniFilterL.parameter+ CausalP.zipWithSimple (MoogL.parameter TypeNum.d8)+{-+FIXME:+This leads to a run-time crash even without LLVM optimizations.+However, I cannot reproduce this in the Test module.+ (CausalP.quantizeLift $# (1 :: Real)) (arr id)++ (CausalP.quantizeLift+ $# (128 / fromIntegral vectorSize :: Real))+ (CausalP.zipWithSimple UniFilterL.parameter)++ (CausalP.quantizeLift+ $# (128 / fromIntegral vectorSize :: Real))+ (CausalP.zipWithSimple (MoogL.parameter TypeNum.d8))+-}+ <<<+ CausalP.feedFst (piecewiseConstant noiseReson)+ <<<+ CausalP.mapSimple Sample.subsampleVector+ <<<+ CausalPS.amplify d))+ in CausalP.zipWithSimple Sample.zipStereo+ <<<+ (osci fst3 0.6 (1*0.999) `mix`+ osci snd3 (0.02 * 50^?vel) (4*0.999) `mix`+ osci thd3 (0.02 * 100^?vel) (7*0.999) `mix`+ noise fst3 0.999) &&&+ (osci fst3 0.6 (1*1.001) `mix`+ osci snd3 (0.02 * 50^?vel) (4*1.001) `mix`+ osci thd3 (0.02 * 100^?vel) (7*1.001) `mix`+ noise fst3 1.001)+ <<<+ CausalP.feedSnd (frequencyFromBendModulation 5 fm)+ <<<+ arr (\(e1,(e4,e7)) -> (e1,e4,e7))+ $> {-+ Be careful, those storable vectors shorten the whole sound+ if they have shorter release than the main envelope.+ -}+ SigP.zip+ (SigP.fromStorableVectorLazy env4)+ (SigP.fromStorableVectorLazy env7)))+ pingReleaseEnvelope+++tine :: IO (Real -> Real -> Instrument Real Vector)+tine =+ liftA2+ (\osc env dec rel vel freq dur ->+ osc (vel,freq) (env dec rel 0 dur))+ (CausalP.runStorableChunky+ (let freq = arr snd+ vel = arr fst+ in CausalP.envelope $>+ (CausalPS.osciSimple WaveL.approxSine2+ $> (SigPS.constant (freq/sampleRate))+ $* (CausalP.envelope+ $< SigPS.exponential2 (1*sampleRate) (vel+1)+ $* SigPS.osciSimple WaveL.approxSine2 zero+ (2*freq/sampleRate)))))+ pingReleaseEnvelope++tineStereo :: IO (Real -> Real -> Instrument Real (Stereo.T Vector))+tineStereo =+ liftA2+ (\osc env dec rel vel freq dur ->+ osc (vel,freq) (env dec rel 0 dur))+ (CausalP.runStorableChunky+ (let freq = arr snd+ vel = arr fst+ chanOsci d =+ CausalPS.osciSimple WaveL.approxSine2+ $> SigPS.constant (freq*d/sampleRate)+ in CausalP.envelopeStereo $>+ ((CausalP.zipWithSimple Sample.zipStereo <<<+ (chanOsci 0.995 &&& chanOsci 1.005))+ $* SigP.envelope+ (SigPS.exponential2 (1*sampleRate) (vel+1))+ (SigPS.osciSimple WaveL.approxSine2 zero+ (2*freq/sampleRate)))))+ pingReleaseEnvelope+++softStringReleaseEnvelope ::+ IO (Real -> Real -> Ev.LazyTime -> SigSt.T Vector)+softStringReleaseEnvelope =+ liftA2+ (\rev env attackTime vel dur ->+ let attackTimeVector =+ div (round (attackTime*sampleRate)) vectorSize+ amp = amplitudeFromVelocity vel+ {-+ release <- take attackTime beginning+ would yield a space leak, thus we first split 'beginning'+ and then concatenate it again+ -}+ {-+ We can not easily generate attack and sustain separately,+ because we want to use the chunk structure implied by 'dur'.+ -}+ (attack, sustain) =+ SigSt.splitAt attackTimeVector $+ env (chunkSizesFromLazyTime dur) (amp, attackTimeVector)+ release = rev attack+ in attack `SigSt.append` sustain `SigSt.append` release)+ SigStL.makeReversePacked+ (let amp = arr fst+ attackTimeVector = arr snd+ in SigP.runChunkyPattern $+ flip SigP.append (SigPS.constant amp) $+ (CausalPS.amplify amp <<<+ CausalP.take attackTimeVector+ $* SigPS.parabolaFadeInInf+ (fmap fromIntegral attackTimeVector *+ fromIntegral vectorSize)))++softString :: IO (Instrument Real (Stereo.T Vector))+softString =+ liftA2+ (\osc env vel freq dur ->+ osc freq (env 1 vel dur))+ (let freq = arr id+ osci d =+ SigPS.osciSimple WaveL.saw zero (d * freq / sampleRate)+ in CausalP.runStorableChunky $+ (CausalP.envelopeStereo $>+ (SigP.zipWithSimple Sample.zipStereo+ (SigP.mix+ (osci 1.005)+ (osci 0.998))+ (SigP.mix+ (osci 1.002)+ (osci 0.995)))))+ softStringReleaseEnvelope+++softStringFM ::+ IO (PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+softStringFM =+ liftA2+ (\osc env fm vel freq dur ->+ osc (fm,freq) (env 1 vel dur))+ (let fm = arr id+ osci ::+ Param.T fm Real ->+ CausalP.T fm (LLVM.Value Vector) (LLVM.Value Vector)+ osci d =+ (CausalPS.osciSimple WaveL.saw $<+ (SigPS.constant $# (zero::Real))) <<<+ CausalPS.amplify d+ in CausalP.runStorableChunky $+ (CausalP.envelopeStereo $>+ (CausalP.zipWithSimple Sample.zipStereo+ <<<+ (CausalP.mix <<< osci 1.005 &&& osci 0.998) &&&+ (CausalP.mix <<< osci 1.002 &&& osci 0.995)+ $* frequencyFromBendModulation 5 fm)))+ softStringReleaseEnvelope+++tineStereoFM ::+ IO (Real -> Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+tineStereoFM =+ liftA2+ (\osc env dec rel fm vel freq dur ->+ osc (vel,(fm,freq)) (env dec rel 0 dur))+ (CausalP.runStorableChunky+ (let vel = arr fst+ fm = arr snd+ chanOsci d =+ CausalPS.osciSimple WaveL.approxSine2+ <<< second (CausalPS.amplify d)+ in CausalP.envelopeStereo $>+ ((CausalP.zipWithSimple Sample.zipStereo <<<+ chanOsci 0.995 &&& chanOsci 1.005)+ <<<+ (((CausalP.envelope+ $< SigPS.exponential2 (1*sampleRate) (vel+1))+ <<< (CausalPS.osciSimple WaveL.approxSine2+ $< (SigPS.constant $# (zero::Real)))+ <<< CausalPS.amplify 2)+ &&& arr id)+ $* frequencyFromBendModulation 5 fm)))+ pingReleaseEnvelope+++tineControlledProc, tineControlledFnProc ::+ Param.T p (PC.T Real) ->+ Param.T p (PC.T Real) ->+ Param.T p Real ->+ CausalP.T p+ (Stereo.T (LLVM.Value Vector))+ (Stereo.T (LLVM.Value Vector))+tineControlledProc index depth vel =+ CausalP.stereoFromMono+ (CausalPS.osciSimple WaveL.approxSine2)+ <<<+ Stereo.interleave+ ^<<+ ((CausalP.envelopeStereo+ $< SigP.envelope+ (piecewiseConstantVector depth)+ (SigPS.exponential2 (1*sampleRate) (vel+1)))+ <<<+ CausalP.stereoFromMono+ (CausalPS.osciSimple WaveL.approxSine2+ $< (SigPS.constant $# (zero::Real)))+ <<<+ (CausalP.envelopeStereo+ $< piecewiseConstantVector index))+ &&& arr id++tineControlledFnProc index depth vel =+ ((\freq ->+ CausalP.stereoFromMono+ (CausalPS.osciSimple WaveL.approxSine2)+ <<<+ Stereo.interleave+ ^<<+ ((CausalP.envelopeStereo+ $< SigP.envelope+ (piecewiseConstantVector depth)+ (SigPS.exponential2 (1*sampleRate) (vel+1)))+ <<<+ CausalP.stereoFromMono+ (CausalPS.osciSimple WaveL.approxSine2+ $< (SigPS.constant $# (zero::Real)))+ <<<+ (CausalP.envelopeStereo+ $< piecewiseConstantVector index)+ <<<+ listen freq)+ &&&+ listen freq)+-- =<<< listen HL.hNil+ =<<< arr HL.hHead)+ <<< arr (\freq -> HL.hCons freq HL.hNil)++tineControlledFM ::+ IO (Real -> Real ->+ PC.T Real ->+ PC.T Real -> PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+tineControlledFM =+ liftA2+ (\osc env dec rel detune index depth fm vel freq dur ->+ osc+ ((index, depth), vel, (detune,fm,freq))+ (env dec rel 0 dur))+ (CausalP.runStorableChunky+ (let index = arr (fst.fst3)+ depth = arr (snd.fst3)+ vel = arr snd3+ fm = arr thd3+ in CausalP.envelopeStereo $>+ (tineControlledFnProc index depth vel $*+ stereoFrequenciesFromDetuneBendModulation 5 fm)))+ pingReleaseEnvelope+++fenderProc ::+ Param.T p (PC.T Real) ->+ Param.T p (PC.T Real) ->+ Param.T p (PC.T Real) ->+ Param.T p Real ->+ CausalP.T p+ (Stereo.T (LLVM.Value Vector))+ (Stereo.T (LLVM.Value Vector))+fenderProc fade index depth vel =+ ((\stereoFreq ->+ let channel_n_1 freq =+ CausalPS.osciSimple WaveL.approxSine2+ <<<+ ((CausalP.envelope+ $< SigP.envelope+ (piecewiseConstantVector depth)+ (SigPS.exponential2 (1*sampleRate) (vel+1)))+ <<<+ (CausalPS.osciSimple WaveL.approxSine2+ $< (SigPS.constant $# (zero::Real)))+ <<<+ (CausalP.envelope+ $< piecewiseConstantVector index)+ <<<+ freq)+ &&&+ freq+ channel_1_2 freq =+ CausalPS.osciSimple WaveL.approxSine2+ <<<+ ((CausalP.envelope+ $< SigP.envelope+ (piecewiseConstantVector depth)+ (SigPS.exponential2 (1*sampleRate) (vel+1)))+ <<<+ (CausalPS.osciSimple WaveL.approxSine2+ $< (SigPS.constant $# (zero::Real)))+ <<<+ freq)+ &&&+ (CausalPS.amplify 2 <<< freq)+ in (CausalP.stereoFromMonoControlled+ (fadeProcess+ (channel_n_1 (arr id))+ (channel_1_2 (arr id)))+ $< piecewiseConstantVector fade)+ <<<+ listen stereoFreq)+ =<<< arr HL.hHead)+ <<< arr (\freq -> HL.hCons freq HL.hNil)++fenderFM ::+ IO (Real -> Real ->+ PC.T Real ->+ PC.T Real -> PC.T Real -> PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+fenderFM =+ liftA2+ (\osc env dec rel detune index depth fade fm vel freq dur ->+ osc+ (((index, depth), fade), vel, (detune,fm,freq))+ (env dec rel 0 dur))+ (CausalP.runStorableChunky+ (let index = arr (fst.fst.fst3)+ depth = arr (snd.fst.fst3)+ fade = arr (snd.fst3)+ vel = arr snd3+ fm = arr thd3+ in CausalP.envelopeStereo $>+ (fenderProc fade index depth vel $*+ stereoFrequenciesFromDetuneBendModulation 5 fm)))+ pingReleaseEnvelope+++tineModulatorBankFM ::+ IO (Real -> Real ->+ PC.T Real ->+ PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+tineModulatorBankFM =+ liftA2+ (\osc env+ dec rel detune+ depth1 depth2 depth3 depth4+ fm vel freq dur ->+ osc+ ((depth1,(depth2,(depth3,(depth4,())))), vel, (detune,fm,freq))+ (env dec rel 0 dur))+ (CausalP.runStorableChunky+ (let depth1 = arr (fst.fst3)+ depth2 = arr (fst.snd.fst3)+ depth3 = arr (fst.snd.snd.fst3)+ depth4 = arr (fst.snd.snd.snd.fst3)+ vel = arr snd3+ fm = arr thd3+ mix x y = CausalP.mixStereo <<< x&&&y+ modulator n depth =+ (CausalP.envelopeStereo+ $< SigP.envelope+ (piecewiseConstantVector depth)+ (SigPS.exponential2 (1*sampleRate) (vel+1)))+ <<<+ CausalP.stereoFromMono+ (CausalPS.osciSimple WaveL.approxSine2+ $< (SigPS.constant $# (zero::Real)))+ <<<+ CausalP.amplifyStereo n+ in CausalP.envelopeStereo $>+ (CausalP.stereoFromMono+ (CausalPS.osciSimple WaveL.approxSine2)+ <<<+ Stereo.interleave+ ^<<+ (modulator 1 depth1 `mix`+ modulator 2 depth2 `mix`+ modulator 3 depth3 `mix`+ modulator 4 depth4)+ &&& arr id+ $*+ stereoFrequenciesFromDetuneBendModulation 5 fm)))+ pingReleaseEnvelope++tineBankFM ::+ IO (Real -> Real ->+ PC.T Real ->+ PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real ->+ PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+tineBankFM =+ liftA2+ (\osc env+ dec rel detune+ depth1 depth2 depth3 depth4+ partial1 partial2 partial3 partial4+ fm vel freq dur ->+ osc+ ((depth1,(depth2,(depth3,(depth4,())))),+ (partial1,(partial2,(partial3,(partial4,())))),+ (vel, (detune,fm,freq)))+ (env dec rel 0 dur))+ (CausalP.runStorableChunky+ (let depth1 = arr (fst.fst3)+ depth2 = arr (fst.snd.fst3)+ depth3 = arr (fst.snd.snd.fst3)+ depth4 = arr (fst.snd.snd.snd.fst3)+ partial1 = arr (fst.snd3)+ partial2 = arr (fst.snd.snd3)+ partial3 = arr (fst.snd.snd.snd3)+ partial4 = arr (fst.snd.snd.snd.snd3)+ vel = arr (fst.thd3)+ fm = arr (snd.thd3)+ mixStereo x y = CausalP.mixStereo <<< x&&&y+ modulator n depth =+ (CausalP.envelopeStereo+ $< SigP.envelope+ (piecewiseConstantVector depth)+ (SigPS.exponential2 (1*sampleRate) (vel+1)))+ <<<+ CausalP.stereoFromMono+ (CausalPS.osciSimple WaveL.approxSine2+ $< (SigPS.constant $# (zero::Real)))+ <<<+ CausalP.amplifyStereo n+ partial ::+ LLVM.Value Vector -> Int32 -> LLVM.Value Vector ->+ LLVM.CodeGenFunction r (LLVM.Value Vector)+ partial amp n t =+ A.mul amp =<<+ WaveL.partial WaveL.approxSine2 (LLVM.valueOf n) t+ in CausalP.envelopeStereo $>+ (CausalP.stereoFromMono+ (CausalPS.shapeModOsci+ (\(p1,(p2,(p3,p4))) t -> do+ y1 <- A.mul p1 =<< WaveL.approxSine2 t+ y2 <- partial p2 2 t+ y3 <- partial p3 3 t+ y4 <- partial p4 4 t+ A.add y1 =<< A.add y2 =<< A.add y3 y4)+ $<+ (SigP.zip (piecewiseConstantVector partial1) $+ SigP.zip (piecewiseConstantVector partial2) $+ SigP.zip (piecewiseConstantVector partial3)+ (piecewiseConstantVector partial4)))+ <<<+ Stereo.interleave+ ^<<+ (modulator 1 depth1 `mixStereo`+ modulator 2 depth2 `mixStereo`+ modulator 3 depth3 `mixStereo`+ modulator 4 depth4)+ &&& arr id+ $*+ stereoFrequenciesFromDetuneBendModulation 5 fm)))+ pingReleaseEnvelope+++{- |+FM synthesis where the modulator is a resonantly filtered sawtooth.+This way we get a sinus-like modulator where the sine frequency+(that is, something like the modulation index) can be controlled continously.+-}+resonantFMSynthProc ::+ Param.T p (PC.T Real) ->+ Param.T p (PC.T Real) ->+ Param.T p (PC.T Real) ->+ Param.T p Real ->+ CausalP.T p+ (Stereo.T (LLVM.Value Vector))+ (Stereo.T (LLVM.Value Vector))+resonantFMSynthProc reson index depth vel =+ ((\stereoFreq ->+ let chan freq =+ CausalPS.osciSimple WaveL.approxSine2+ <<<+ ((CausalP.envelope+ $< SigP.envelope+ (piecewiseConstantVector depth)+ (SigPS.exponential2 (1*sampleRate) (vel+1)))+ <<<+ UniFilter.lowpass+ ^<<+ CtrlPS.process+ <<<+ (CausalP.zipWithSimple UniFilterL.parameter+ <<<+ CausalP.feedFst (piecewiseConstant reson)+ <<<+ (CausalP.envelope $< piecewiseConstant index)+ <<<+ CausalP.mapSimple Sample.subsampleVector+ <<<+ freq)+ &&&+ ((CausalPS.osciSimple WaveL.saw+ $< (SigPS.constant $# (zero::Real)))+ <<<+ freq))+ &&&+ freq+ in CausalP.stereoFromMono (chan (arr id))+ <<<+ listen stereoFreq)+ =<<< arr HL.hHead)+ <<< arr (\freq -> HL.hCons freq HL.hNil)++resonantFMSynth ::+ IO (Real -> Real ->+ PC.T Real ->+ PC.T Real -> PC.T Real -> PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+resonantFMSynth =+ liftA2+ (\osc env dec rel detune reson index depth fm vel freq dur ->+ osc+ ((reson, index, depth), vel, (detune,fm,freq))+ (env dec rel 0 dur))+ (CausalP.runStorableChunky+ (let reson = arr (fst3.fst3)+ index = arr (snd3.fst3)+ depth = arr (thd3.fst3)+ vel = arr snd3+ fm = arr thd3+ in CausalP.envelopeStereo $>+ (resonantFMSynthProc reson index depth vel $*+ stereoFrequenciesFromDetuneBendModulation 5 fm)))+ pingReleaseEnvelope+++piecewiseConstantVector ::+ Param.T p (PC.T Real) -> SigP.T p (LLVM.Value Vector)+{-+ (Storable a,+ LLVM.MakeValueTuple a al,+ Rep.Memory al am,+ LLVM.IsSized am as) =>+ Param.T p (PC.T a) -> SigP.T p (LLVM.Vector n al)+-}+piecewiseConstantVector pc =+ SigP.mapSimple SoV.replicate $+ piecewiseConstant pc+++softStringDetuneFM ::+ IO (Real ->+ PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+softStringDetuneFM =+ liftA2+ (\osc env att det fm vel freq dur ->+ osc (det, (fm,freq)) (env att vel dur))+ (let det = arr fst+ fm = arr snd+ mix x y = CausalP.mix <<< x&&&y+ osci ::+ Param.T (det,fm) Real ->+ CausalP.T (det,fm)+ (LLVM.Value Vector, LLVM.Value Vector)+ (LLVM.Value Vector)+ osci d =+ (CausalPS.osciSimple WaveL.saw $<+ (SigPS.constant $# (zero::Real)))+ <<<+ CausalP.envelope+ <<<+ first (CausalPS.raise 1 <<< CausalPS.amplify d)+ in CausalP.runStorableChunky $+ (CausalP.envelopeStereo $>+ (CausalPS.amplifyStereo 0.25+ <<<+ CausalP.zipWithSimple Sample.zipStereo+ <<<+ ((osci 1.0 `mix` osci (-0.4)) `mix`+ (osci 0.5 `mix` osci (-0.7))) &&&+ ((osci 0.4 `mix` osci (-1.0)) `mix`+ (osci 0.7 `mix` osci (-0.5)))+ <<<+ CausalP.feedFst (piecewiseConstantVector det)+ $* frequencyFromBendModulation 5 fm)))+ softStringReleaseEnvelope++{-+We might decouple the frequency of the enveloped tone+from the frequency of the envelope,+in order to get something like formants.+-}+softStringShapeFM, cosineStringStereoFM,+ arcSineStringStereoFM, arcTriangleStringStereoFM,+ arcSquareStringStereoFM, arcSawStringStereoFM ::+ IO (Real ->+ PC.T Real ->+ PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+softStringShapeFM =+ softStringShapeCore WaveL.rationalApproxSine1+cosineStringStereoFM =+ softStringShapeCore+ (\k p -> WaveL.approxSine2 =<< WaveL.replicate k p)+arcSawStringStereoFM = arcStringStereoFM WaveL.saw+arcSineStringStereoFM = arcStringStereoFM WaveL.approxSine2+arcSquareStringStereoFM = arcStringStereoFM WaveL.square+arcTriangleStringStereoFM = arcStringStereoFM WaveL.triangle++arcStringStereoFM ::+ (forall r.+ LLVM.Value Vector ->+ LLVM.CodeGenFunction r (LLVM.Value Vector)) ->+ IO (Real ->+ PC.T Real ->+ PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+arcStringStereoFM wave =+ softStringShapeCore+ (\k p ->+ LM.liftR2 Sample.amplifyMono+ (WaveL.approxSine4 =<< WaveL.halfEnvelope p)+ (wave =<< WaveL.replicate k p))++softStringShapeCore ::+ (forall r.+ LLVM.Value Vector ->+ LLVM.Value Vector ->+ LLVM.CodeGenFunction r (LLVM.Value Vector)) ->+ IO (Real ->+ PC.T Real ->+ PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+softStringShapeCore wave =+ liftA2+ (\osc env att det dist fm vel freq dur ->+ osc ((det, dist), (fm,freq)) (env att vel dur))+ (let det = arr (fst.fst)+ dist = arr (snd.fst)+ fm = arr snd+ mix x y = CausalP.mix <<< x&&&y+ osci ::+ Param.T (mod,fm) Real ->+ CausalP.T (mod,fm)+ (LLVM.Value Vector,+ {- wave shape parameter -}+ (LLVM.Value Vector, LLVM.Value Vector)+ {- detune, frequency modulation -})+ (LLVM.Value Vector)+ osci d =+ CausalPS.shapeModOsci wave+ <<<+ second+ (CausalP.feedFst (SigPS.constant $# (zero::Real))+ <<<+ CausalP.envelope+ <<<+ first (CausalPS.raise 1 <<< CausalPS.amplify d))+ in CausalP.runStorableChunky $+ (CausalP.envelopeStereo $>+ (CausalPS.amplifyStereo 0.25+ <<<+ CausalP.zipWithSimple Sample.zipStereo+ <<<+ ((osci 1.0 `mix` osci (-0.4)) `mix`+ (osci 0.5 `mix` osci (-0.7))) &&&+ ((osci 0.4 `mix` osci (-1.0)) `mix`+ (osci 0.7 `mix` osci (-0.5)))+ $< piecewiseConstantVector dist+ $< piecewiseConstantVector det+ $* frequencyFromBendModulation 5 fm)))+ softStringReleaseEnvelope++fmStringStereoFM ::+ IO (Real ->+ PC.T Real ->+ PC.T Real ->+ PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+fmStringStereoFM =+ liftA2+ (\osc env att det depth dist fm vel freq dur ->+ osc ((det, depth, dist), (fm, freq)) (env att vel dur))+ (let det = arr (fst3.fst)+ depth = arr (snd3.fst)+ dist = arr (thd3.fst)+ fm = arr snd+ mix x y = CausalP.mix <<< x&&&y+ osci ::+ Param.T (mod,fm) Real ->+ CausalP.T (mod,fm)+ ((LLVM.Value Vector, LLVM.Value Vector)+ {- phase modulation depth, modulator distortion -},+ (LLVM.Value Vector, LLVM.Value Vector)+ {- detune, frequency modulation -})+ (LLVM.Value Vector)+ osci d =+ CausalPS.osciSimple WaveL.approxSine2+ <<<+ (CausalP.envelope+ <<<+ second+ (CausalPS.shapeModOsci WaveL.rationalApproxSine1+ <<< second (CausalP.feedFst (SigPS.constant 0)))+ <<^+ (\((dp, ds), f) -> (dp, (ds, f))))+ &&& arr snd+ <<<+ second+ (CausalP.envelope <<<+ first (CausalPS.raise 1 <<< CausalPS.amplify d))+ in CausalP.runStorableChunky+ (CausalP.envelopeStereo <<<+ (arr id &&&+ (CausalPS.amplifyStereo 0.25+ <<<+ CausalP.zipWithSimple Sample.zipStereo+ <<<+ ((osci 1.0 `mix` osci (-0.4)) `mix`+ (osci 0.5 `mix` osci (-0.7))) &&&+ ((osci 0.4 `mix` osci (-1.0)) `mix`+ (osci 0.7 `mix` osci (-0.5)))+ <<<+ CausalP.feedSnd+ (SigP.zip+ (piecewiseConstantVector det)+ (frequencyFromBendModulation 5 fm))+ <<<+ CausalP.feedSnd (piecewiseConstantVector dist)+ <<<+ (CausalP.envelope+ $< piecewiseConstantVector depth)))))+ softStringReleaseEnvelope+++wind ::+ IO (Real ->+ PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+wind =+ liftA2+ (\osc env att reson fm vel freq dur ->+ osc (reson, (fm,freq)) (env att vel dur))+ (let reson = arr fst+ fm = arr snd+ in CausalP.runStorableChunky $+ (CausalP.envelopeStereo $>+ (CausalP.stereoFromMonoControlled CtrlPS.process+ $< SigP.zipWithSimple+ (MoogL.parameter TypeNum.d8)+ (piecewiseConstant reson)+ (SigP.mapSimple Sample.subsampleVector+ (frequencyFromBendModulation 0.2 fm))+ $* SigP.zipWithSimple Sample.zipStereo+ (SigPS.noise 13 (sampleRate/20000))+ (SigPS.noise 14 (sampleRate/20000)+ :: SigP.T p (LLVM.Value Vector)))))+ softStringReleaseEnvelope+++fadeProcess ::+ (Num b, LLVM.IsConst b,+ LLVM.IsArithmetic v, SoV.Replicate b v) =>+ CausalP.T p a (LLVM.Value v) ->+ CausalP.T p a (LLVM.Value v) ->+ CausalP.T p (LLVM.Value v, a) (LLVM.Value v)+fadeProcess proc0 proc1 =+ CausalP.mapSimple+ (\(k,(a0,a1)) -> do+ b0 <- A.mul a0 =<< A.sub (SoV.replicateOf 1) k+ b1 <- A.mul a1 k+ A.add b0 b1)+ <<<+ second (proc0 &&& proc1)++windPhaser ::+ IO (Real ->+ PC.T Real ->+ PC.T Real ->+ PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+windPhaser =+ liftA2+ (\osc env att phaserMix phaserFreq reson fm vel freq dur ->+ osc ((phaserMix,phaserFreq), reson, (fm,freq)) (env att vel dur))+ (let phaserMix = arr (fst.fst3)+ phaserFreq = arr (snd.fst3)+ reson = arr snd3+ fm = arr thd3+ in CausalP.runStorableChunky $+ (CausalP.envelopeStereo $>+ ((CausalP.stereoFromMonoControlled+ (fadeProcess (arr snd) CtrlPS.process+ <<<+ first (CausalP.mapSimple SoV.replicate)+ <<^+ (\((k,p),x) -> (k,(p,x))))+ $< SigP.zip+ (piecewiseConstant phaserMix)+ (piecewiseConstant+ (fmap+ (Allpass.flangerParameterPlain TypeNum.d8 .+ (/sampleRate))+ ^<< phaserFreq)))+ <<<+ CausalP.stereoFromMonoControlled CtrlPS.process+ $< SigP.zipWithSimple+ (MoogL.parameter TypeNum.d8)+ (piecewiseConstant reson)+ (SigP.mapSimple Sample.subsampleVector+ (frequencyFromBendModulation 0.2 fm))+ $* SigP.zipWithSimple Sample.zipStereo+ (SigPS.noise 13 (sampleRate/20000))+ (SigPS.noise 14 (sampleRate/20000)+ :: SigP.T p (LLVM.Value Vector)))))+ softStringReleaseEnvelope+++filterSawStereoFM ::+ IO (Real -> Real ->+ PC.T Real ->+ Real -> Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+filterSawStereoFM =+ liftA2+ (\osc env dec rel detune bright brightDecay fm vel freq dur ->+ osc ((bright, brightDecay), (detune,fm,freq)) (env dec rel vel dur))+ (CausalP.runStorableChunky+ (let bright = arr (fst.fst)+ brightDec = arr (snd.fst)+ fm = arr snd+ in CausalP.envelopeStereo $>+ (CausalP.stereoFromMono+ (UniFilter.lowpass+ ^<<+ (CtrlPS.processCtrlRate $# (100::Real))+ (\k -> SigP.mapSimple+ (UniFilterL.parameter (LLVM.valueOf 10))+ {- bound control in order to avoid too low resonant frequency,+ which makes the filter instable -}+ (SigP.exponentialBounded2+ (100/sampleRate)+ (brightDec*sampleRate/k)+ (bright/sampleRate)))+ <<<+ CausalPS.osciSimple WaveL.saw $< SigPS.constant zero)+ $* stereoFrequenciesFromDetuneBendModulation 10 fm)))+ pingReleaseEnvelope+++{- |+The ADSR curve is composed from three parts:+Attack, Decay(+Sustain), Release.+Attack starts when the key is pressed+and lasts attackTime seconds+where it reaches height attackPeak*amplitudeOfVelocity.+It should be attackPeak>1 because in the following phase+we want to approach 1 from above.+Say the curve would approach the limit value L+if it would continue after the end of the attack phase,+the slope is determined by the halfLife with respect to this upper bound.+That is, attackHalfLife is the time in seconds where the attack curve+reaches or would reach L/2.+After Attack the Decay part starts at the same level+and decays to amplitudeOfVelocity.+The slope is again a halfLife,+that is, decayHalfLife is the time where the curve+drops from attackPeak*amplitudeOfVelocity to (attackPeak+1)/2*amplitudeOfVelocity.+This phase lasts as long as the key is pressed.+If the key is released the curve decays with half life releaseHalfLife.+-}+{-+1 - 2^(-attackTime/attackHalfLife) = peak+-}+adsr ::+ IO (Real -> Real -> Real ->+ Real -> Real ->+ Real -> Ev.LazyTime -> SigSt.T Vector)+adsr =+ liftA3+ (\attack decay release+ attackTime attackPeak attackHalfLife+ decayHalfLife releaseHalfLife vel dur ->+ let amp = amplitudeFromVelocity vel+ (attackDur, decayDur) =+ CutG.splitAt (round (attackTime*vectorRate)) dur+ in SigStL.continuePacked+ (attack (chunkSizesFromLazyTime attackDur)+ (attackHalfLife,+ attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife)))+ `SigSt.append`+ decay (chunkSizesFromLazyTime decayDur)+ (decayHalfLife,+ ((attackPeak-1)*amp, amp)))+ (\x -> release vectorChunkSize (releaseHalfLife,x)))+ (SigP.runChunkyPattern $+ let halfLife = arr fst+ amplitude = arr snd+ in SigP.zipWithSimple A.sub+ (SigPS.constant amplitude)+ (SigPS.exponential2 (halfLife*sampleRate) amplitude))+ (SigP.runChunkyPattern $+ let halfLife = arr fst+ amplitude = arr (fst.snd)+ saturation = arr (snd.snd)+ in SigP.mix (SigPS.constant saturation) $+ SigPS.exponential2 (halfLife*sampleRate) amplitude)+ (SigP.runChunky $+ let release = arr fst+ amplitude = arr snd+ in (CausalP.take (round ^<< (release*5*vectorRate)) $*+ SigPS.exponential2 (release*sampleRate) amplitude))++brass ::+ IO (Real -> Real ->+ Real -> Real -> Real -> Real ->+ PC.T Real ->+ PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+brass =+ liftA2+ (\osc env attTime attPeak attHL dec rel emph det dist fm vel freq dur ->+ osc+ ((det, dist), (fm,freq),+ env attTime emph attHL dec rel vel dur)+ (env attTime attPeak attHL dec rel vel dur))+ (let det = arr (fst.fst3)+ dist = arr (snd.fst3)+ fm = arr snd3+ emph = arr thd3+ mix x y = CausalP.mix <<< x&&&y+ osci ::+ Param.T p Real ->+ CausalP.T p+ (LLVM.Value Vector,+ {- wave shrink/replication factor -}+ (LLVM.Value Vector, LLVM.Value Vector)+ {- detune, frequency modulation -})+ (LLVM.Value Vector)+ osci d =+ CausalPS.shapeModOsci WaveL.rationalApproxSine1+ <<<+ second+ (CausalP.feedFst (SigPS.constant $# (zero::Real))+ <<<+ CausalP.envelope+ <<<+ first (CausalPS.raise 1 <<< CausalPS.amplify d))+ in CausalP.runStorableChunky $+ (CausalP.envelopeStereo $>+ (CausalPS.amplifyStereo 0.25+ <<<+ CausalP.zipWithSimple Sample.zipStereo+ <<<+ ((osci 1.0 `mix` osci (-0.4)) `mix`+ (osci 0.5 `mix` osci (-0.7))) &&&+ ((osci 0.4 `mix` osci (-1.0)) `mix`+ (osci 0.7 `mix` osci (-0.5)))+ <<<+ CausalP.feedFst (piecewiseConstantVector dist)+ <<<+ CausalP.feedSnd (frequencyFromBendModulation 5 fm)+ <<<+ (CausalP.envelope $< piecewiseConstantVector det)+ $*+ SigP.fromStorableVectorLazy emph)))+ adsr+++data SamplePositions =+ SamplePositions {+ sampleStart, sampleLength,+ sampleLoopStart, sampleLoopLength :: Int+ }++data SampledSound =+ SampledSound {+ sampleData :: SigSt.T Real,+ samplePositions :: SamplePositions,+ samplePeriod :: Real+ }+++sampledSound ::+ IO (SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSound =+ liftA2+ (\osc freqMod smp fm vel freq dur ->+ {-+ We split the frequency modulation signal+ in order to get a smooth frequency modulation curve.+ Without (periodic) frequency modulation+ we could just split the piecewise constant control curve @fm@.+ -}+ let fmSig =+ freqMod+ (chunkSizesFromLazyTime (PC.duration fm))+ (fm, freq*samplePeriod smp) :: SigSt.T Vector+ pos = samplePositions smp+ amp = 2 * amplitudeFromVelocity vel+ (attack,sustain) =+ mapPair+ (SigSt.drop (sampleStart pos),+ SigSt.take (sampleLoopLength pos)) $+ SigSt.splitAt (sampleLoopStart pos) $+ sampleData smp+ release =+ SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $+ SigSt.take (sampleStart pos + sampleLength pos) $+ sampleData smp+ in (\cont -> osc cont+ (amp,+ attack `SigSt.append`+ SVL.cycle (SigSt.take (sampleLoopLength pos) sustain),+ chunkSizesFromLazyTime dur)+ fmSig)+ (osc (const SigSt.empty)+ (amp, release, NonNegChunky.fromChunks (repeat 1000))))+ (CausalP.runStorableChunkyCont+ (let amp = arr fst3+ smp = arr snd3+ dur = arr thd3+ in CausalPS.amplifyStereo amp+ <<<+ CausalP.stereoFromMono+ (CausalPS.pack+ (CausalP.frequencyModulationLinear+ (SigP.fromStorableVectorLazy smp)))+ <<<+ CausalP.zipWithSimple Sample.zipStereo+ <<<+ CausalPS.amplify 0.999 &&&+ CausalPS.amplify 1.001+ <<<+ arr fst+ <<<+ CausalP.feedSnd (SigP.lazySize dur)))+ (SigP.runChunkyPattern+ (frequencyFromBendModulation 3 (arr id)))+++sampledSoundLeaky ::+ IO (SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundLeaky =+ liftA2+ (\osc freqMod smp fm vel freq dur ->+ {-+ We split the frequency modulation signal+ in order to get a smooth frequency modulation curve.+ Without (periodic) frequency modulation+ we could just split the piecewise constant control curve @fm@.+ -}+ let (sustainFM, releaseFM) =+ SVP.splitAt (chunkSizesFromLazyTime dur) $+ (freqMod+ (chunkSizesFromLazyTime (PC.duration fm))+ (fm, freq*samplePeriod smp) :: SigSt.T Vector)+ pos = samplePositions smp+ amp = 2 * amplitudeFromVelocity vel+ (attack,sustain) =+ mapPair+ (SigSt.drop (sampleStart pos),+ SigSt.take (sampleLoopLength pos)) $+ SigSt.splitAt (sampleLoopStart pos) $+ sampleData smp+ release =+ SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $+ SigSt.take (sampleStart pos + sampleLength pos) $+ sampleData smp+ in osc+ (amp,+ attack `SigSt.append`+ SVL.cycle (SigSt.take (sampleLoopLength pos) sustain))+ sustainFM+ `SigSt.append`+ osc (amp,release) releaseFM)+ (CausalP.runStorableChunky+ (let smp = arr snd+ amp = arr fst+ in CausalPS.amplifyStereo amp+ <<<+ CausalP.stereoFromMono+ (CausalPS.pack+ (CausalP.frequencyModulationLinear+ (SigP.fromStorableVectorLazy smp)))+ <<<+ CausalP.zipWithSimple Sample.zipStereo+ <<<+ CausalPS.amplify 0.999 &&&+ CausalPS.amplify 1.001))+ (SigP.runChunkyPattern+ (frequencyFromBendModulation 3 (arr id)))+++type SampleInfo = (FilePath, [SamplePositions], Real)++makeSampledSounds ::+ SampleInfo ->+ IO [-- PC.T Real ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector)]+makeSampledSounds (path, positions, period) = do+{-+ sound <-+ (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<+ SoxRead.open SoxOption.none "speech/tomatensalat2.wav")+ play (44100::Real) (sound::SVL.Vector Real)+-}+ liftA2+ (\makeSmp smp ->+ map (\pos -> makeSmp (SampledSound smp pos period))+ positions)+ sampledSound+ (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<+ SoxRead.open SoxOption.none path)+++tomatensalatPositions :: [SamplePositions]+tomatensalatPositions =+ SamplePositions 0 29499 12501 15073 :+ SamplePositions 29499 31672 38163 17312 :+ SamplePositions 67379 28610 81811 10667 :+ SamplePositions 95989 31253 106058 16111 :+ SamplePositions 127242 38596 136689 11514 :+ []++tomatensalat :: SampleInfo+tomatensalat =+ ("speech/tomatensalat2.wav", tomatensalatPositions, 324.5)+++halPositions :: [SamplePositions]+halPositions =+-- SamplePositions 2371 25957 7362 6321 :+ SamplePositions 2371 25957 (2371+25957) 1 :+ SamplePositions 40546 34460 63540 9546 :+ SamplePositions 79128 32348 94367 14016 :+ SamplePositions 112027 21227 125880 5500 :+ SamplePositions 146057 23235 168941 352 :+ []++hal :: SampleInfo+hal =+ ("speech/haskell-in-leipzig2.wav", halPositions, 316)+++graphentheoriePositions :: [SamplePositions]+graphentheoriePositions =+ SamplePositions 0 29524 13267 14768 :+ SamplePositions 29524 35333 47624 9968 :+ SamplePositions 64857 31189 73818 16408 :+ SamplePositions 96046 31312 106206 18504 :+ SamplePositions 127358 32127 132469 16530 :+ []++graphentheorie :: SampleInfo+graphentheorie =+ ("speech/graphentheorie0.wav", graphentheoriePositions, 301.15)
+ src/Synthesizer/LLVM/Server/Packed/Run.hs view
@@ -0,0 +1,422 @@+module Synthesizer.LLVM.Server.Packed.Run where++import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr+import Synthesizer.LLVM.Server.Packed.Instrument+ (Vector, vectorSize, vectorChunkSize, )+import Synthesizer.LLVM.Server.Common++import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Synthesizer.EventList.ALSA.MIDI as Ev+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS+import qualified Synthesizer.Generic.ALSA.MIDI as Gen++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+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.Parameterized.Signal (($#), )++import qualified LLVM.Core as LLVM++import qualified Synthesizer.Storable.Signal as SigSt++import qualified Synthesizer.Plain.Filter.Recursive as FiltR+import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel as ChannelMsg++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Data.EventList.Relative.MixedTime as EventListMT++import Synthesizer.ApplicativeUtility (liftA4, liftA5, liftA6, )+import Control.Arrow ((<<<), (^<<), {- (<<^), -} (&&&), {- (***), -} arr, first, {- second, -} )+import Control.Applicative (pure, {- liftA, -} liftA2, liftA3, (<*>), )+import Control.Monad.Trans.State (evalState, )++{-+import Data.Tuple.HT (mapPair, fst3, snd3, thd3, )++import qualified Numeric.NonNegative.Class as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky as NonNegChunky+-}++-- import qualified Algebra.RealRing as RealRing+import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric (zero, round, )+import Prelude hiding (Real, round, break, )++++{-# INLINE withMIDIEventsMono #-}+withMIDIEventsMono ::+ (Double -> Double -> SigSt.T Real -> IO b) ->+ (EventList.T Ev.StrictTime [Event.T] -> SigSt.T Vector) -> IO b+withMIDIEventsMono action proc =+ let rate = sampleRate+ per = periodTime+ in Ev.withMIDIEvents per (rate / fromIntegral vectorSize) $+ action per rate . SigStL.unpack . proc++{-# INLINE withMIDIEventsStereo #-}+withMIDIEventsStereo ::+ (Double -> Double -> SigSt.T (Stereo.T Real) -> IO b) ->+ (EventList.T Ev.StrictTime [Event.T] -> SigSt.T (Stereo.T Vector)) ->+ IO b+withMIDIEventsStereo action proc =+ let rate = sampleRate+ per = periodTime+ in do unpack <- SigStL.makeUnpackGeneric+ Ev.withMIDIEvents per (rate / fromIntegral vectorSize) $+ action per rate . unpack . proc+++-- maybe this can be merged into a PCS.controllerDiscrete+stair :: Real -> Real+stair i =+ let n = fromIntegral (round i :: Int)+ r = i - n+ in n + 0.01*r+++frequencyModulation :: IO ()+frequencyModulation = do+ osc <-+ SigP.runChunky+ ((CausalPS.osciSimple WaveL.triangle $<# (LLVM.vector [zero] :: Vector))+ $* Instr.frequencyFromBendModulation 10 (arr id &&& pure 880))+ withMIDIEventsMono play $+ osc vectorChunkSize .+ evalState (PC.bendWheelPressure channel 2 0.04 (0.03::Real))++++keyboard :: IO ()+keyboard = do+ sound <- Instr.pingRelease $/ 0.4 $/ 0.1+ amp <- CausalP.runStorableChunky (CausalPS.amplify $# 0.2)+ arrange <- SigStL.makeArranger+ withMIDIEventsMono play $+ (amp () :: SigSt.T Vector -> SigSt.T Vector) .+ evalState (Gen.sequence (arrange vectorChunkSize) channel sound)++keyboardStereo :: IO ()+keyboardStereo = do+ sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1+ amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2)+ arrange <- SigStL.makeArranger+ withMIDIEventsStereo play $+ (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) .+ evalState (Gen.sequence (arrange vectorChunkSize) channel sound)+++keyboardFM :: IO ()+keyboardFM = do+ str <- Instr.softStringFM+ amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2)+ arrange <- SigStL.makeArranger+ withMIDIEventsStereo play $+ (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) .+ evalState+ (do fm <- PC.bendWheelPressure channel 2 0.04 0.03+ Gen.sequenceModulated (arrange vectorChunkSize) fm channel str)++keyboardFMMulti :: IO ()+keyboardFMMulti = do+ str <- Instr.softStringFM+ tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1+ amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2)+ arrange <- SigStL.makeArranger+ withMIDIEventsStereo play $+ (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) .+ evalState+ (do fm <- PC.bendWheelPressure channel 2 0.04 0.03+ Gen.sequenceModulatedMultiProgram+ (arrange vectorChunkSize) fm channel+ (VoiceMsg.toProgram 1)+ [str, tin])+++controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1,+ controllerFilterCutoff, controllerFilterResonance,+ controllerGlobal, controllerVolume :: VoiceMsg.Controller+[controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1,+ controllerFilterCutoff, controllerFilterResonance,+ controllerGlobal, controllerVolume] =+ map VoiceMsg.toController [21, 22, 23, 24, 91, 93, 82, 83]++controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4,+ controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4+ :: VoiceMsg.Controller+[controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4,+ controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4] =+ map VoiceMsg.toController [25, 26, 27, 28, 70, 71, 72, 73]++keyboardDetuneFMCore ::+ IO (ChannelMsg.Channel -> VoiceMsg.Program ->+ Ev.Filter (SigSt.T (Stereo.T Vector)))+keyboardDetuneFMCore = do+ str0 <- Instr.softStringDetuneFM+ ssh0 <- Instr.softStringShapeFM+ css0 <- Instr.cosineStringStereoFM+ asw0 <- Instr.arcSawStringStereoFM+ asn0 <- Instr.arcSineStringStereoFM+ asq0 <- Instr.arcSquareStringStereoFM+ atr0 <- Instr.arcTriangleStringStereoFM+ wnd0 <- Instr.wind+ wnp0 <- Instr.windPhaser+ fms0 <- Instr.fmStringStereoFM+ tin0 <- Instr.tineStereoFM+ tnc0 <- Instr.tineControlledFM+ fnd0 <- Instr.fenderFM+ tnb0 <- Instr.tineBankFM+ rfm0 <- Instr.resonantFMSynth+ png0 <- Instr.pingStereoRelease+ pngFM0 <- Instr.pingStereoReleaseFM+ sqr0 <- Instr.squareStereoReleaseFM+ bel0 <- Instr.bellStereoFM+ ben0 <- Instr.bellNoiseStereoFM+ flt0 <- Instr.filterSawStereoFM+ brs0 <- Instr.brass+ tmt0 <- Instr.makeSampledSounds Instr.tomatensalat+ hal0 <- Instr.makeSampledSounds Instr.hal+ grp0 <- Instr.makeSampledSounds Instr.graphentheorie++ let evHead =+ fmap (EventListMT.switchBodyL+ (error "empty controller stream") const)+ flt = evalState $+ liftA5 (\rel -> flt0 (4*rel) rel)+ (evHead $+ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)+ (PCS.controllerLinear controllerDetune (0,0.005) 0.001)+ (evHead $+ PCS.controllerExponential controllerTimbre0 (100,10000) 1000)+ (evHead $+ PCS.controllerExponential controllerTimbre1 (0.1,1) 0.1)+ (PCS.bendWheelPressure 2 0.04 0.03)+ png =+ (\rel -> png0 (4*rel) rel) .+ evalState+ (evHead $+ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)+ pngFM = evalState $+ liftA5 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs)+ (evHead $+ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)+ (PCS.controllerLinear controllerDetune (0,0.005) 0.001)+ (evHead $+ PCS.controllerLinear controllerTimbre0 (0,1) 1)+ (PCS.controllerExponential controllerTimbre1 (0.3,0.001) 0.05)+ (PCS.bendWheelPressure 2 0.04 0.03)+ sqr = evalState $+ liftA5 (\rel -> sqr0 (4*rel) rel)+ (evHead $+ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)+ (PCS.controllerLinear controllerDetune (0,0.005) 0.001)+ (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05)+ (PCS.controllerLinear controllerTimbre1 (0,0.25) 0.25)+ (PCS.bendWheelPressure 2 0.04 0.03)+ tin = evalState $+ liftA2 (\rel -> tin0 (4*rel) rel)+ (evHead $+ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)+ (PCS.bendWheelPressure 2 0.04 0.03)+ tnc = evalState $+ liftA5 (\rel -> tnc0 (4*rel) rel)+ (evHead $+ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)+ (PCS.controllerLinear controllerDetune (0,0.005) 0.001)+ (fmap (fmap stair) $+ PCS.controllerLinear controllerTimbre0 (0.5,6.5) 2)+ (PCS.controllerLinear controllerTimbre1 (0,1.5) 1)+ (PCS.bendWheelPressure 2 0.04 0.03)+ fnd = evalState $+ liftA6 (\rel -> fnd0 (4*rel) rel)+ (evHead $+ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)+ (PCS.controllerLinear controllerDetune (0,0.005) 0.001)+ (fmap (fmap stair) $+ PCS.controllerLinear controllerTimbre0 (0.5,20.5) 14)+ (PCS.controllerLinear controllerTimbre1 (0,1.5) 0.3)+ (PCS.controllerLinear controllerFMDepth1 (0,1) 0.25)+ (PCS.bendWheelPressure 2 0.04 0.03)+ tnb = evalState $+ pure (\rel -> tnb0 (4*rel) rel)+ <*> (evHead $+ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)+ <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001)+ <*> (PCS.controllerLinear controllerFMDepth1 (0,2) 0)+ <*> (PCS.controllerLinear controllerFMDepth2 (0,2) 0)+ <*> (PCS.controllerLinear controllerFMDepth3 (0,2) 0)+ <*> (PCS.controllerLinear controllerFMDepth4 (0,2) 0)+ <*> (PCS.controllerLinear controllerFMPartial1 (0,1) 1)+ <*> (PCS.controllerLinear controllerFMPartial2 (0,1) 0)+ <*> (PCS.controllerLinear controllerFMPartial3 (0,1) 0)+ <*> (PCS.controllerLinear controllerFMPartial4 (0,1) 0)+ <*> (PCS.bendWheelPressure 2 0.04 0.03)+ rfm = evalState $+ liftA6 (\rel -> rfm0 (4*rel) rel)+ (evHead $+ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)+ (PCS.controllerLinear controllerDetune (0,0.005) 0.001)+ (PCS.controllerExponential controllerTimbre1 (1,100) 30)+ (PCS.controllerLinear controllerTimbre0 (1,15) 3)+ (PCS.controllerExponential controllerFMDepth1 (0.005,0.5) 0.1)+ (PCS.bendWheelPressure 2 0.04 0.03)+ bel = evalState $+ liftA3 (\rel -> bel0 (2*rel) rel)+ (evHead $+ PCS.controllerExponential controllerAttack (0.03,1.0) 0.3)+ (PCS.controllerLinear controllerDetune (0,0.005) 0.001)+ (PCS.bendWheelPressure 2 0.05 0.02)+ ben = evalState $+ liftA4 (\rel -> ben0 (2*rel) rel)+ (evHead $+ PCS.controllerExponential controllerAttack (0.03,1.0) 0.3)+ (PCS.controllerLinear controllerTimbre0 (0,1) 0.3)+ (PCS.controllerExponential controllerTimbre1 (1,1000) 100)+ (PCS.bendWheelPressure 2 0.05 0.02)+ str = evalState $+ liftA3 str0+ (evHead $+ PCS.controllerExponential controllerAttack (0.02,2) 0.5)+ (PCS.controllerLinear controllerDetune (0,0.01) 0.005)+ (PCS.bendWheelPressure 2 0.04 0.03)+ ssh = evalState $+ liftA4 ssh0+ (evHead $+ PCS.controllerExponential controllerAttack (0.02,2) 0.5)+ (PCS.controllerLinear controllerDetune (0,0.01) 0.005)+ (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05)+ (PCS.bendWheelPressure 2 0.04 0.03)+ makeArc gen = evalState $+ liftA4 gen+ (evHead $+ PCS.controllerExponential controllerAttack (0.02,2) 0.5)+ (PCS.controllerLinear controllerDetune (0,0.01) 0.005)+ (PCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5)+ (PCS.bendWheelPressure 2 0.04 0.03)+ css = makeArc css0+ asw = makeArc asw0+ asn = makeArc asn0+ asq = makeArc asq0+ atr = makeArc atr0+ fms = evalState $+ liftA5 fms0+ (evHead $+ PCS.controllerExponential controllerAttack (0.02,2) 0.5)+ (PCS.controllerLinear controllerDetune (0,0.01) 0.005)+ (PCS.controllerLinear controllerTimbre0 (0,0.5) 0.2)+ (PCS.controllerExponential controllerTimbre1 (0.001,10) 0.1)+ (PCS.bendWheelPressure 2 0.04 0.03)+ wnd = evalState $+ liftA3 wnd0+ (evHead $+ PCS.controllerExponential controllerAttack (0.02,2) 0.5)+ (PCS.controllerExponential controllerTimbre1 (1,1000) 100)+ (PCS.bendWheelPressure 12 0.8 0)+ wnp = evalState $+ liftA5 wnp0+ (evHead $+ PCS.controllerExponential controllerAttack (0.02,2) 0.5)+ (PCS.controllerLinear controllerTimbre0 (0,1) 0.5)+ (PCS.controllerExponential controllerDetune (50,5000) 500)+ (PCS.controllerExponential controllerTimbre1 (1,1000) 100)+ (PCS.bendWheelPressure 12 0.8 0)+ brs = evalState $+ liftA5+ (\rel det t0 peak -> brs0 (rel/2) 1.5 (rel/2) rel rel peak det t0)+ (evHead $+ PCS.controllerExponential controllerAttack (0.01,0.1) 0.01)+ (PCS.controllerLinear controllerDetune (0,0.01) 0.005)+ (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05)+ (evHead $+ PCS.controllerLinear controllerTimbre1 (1,5) 3)+ (PCS.bendWheelPressure 2 0.04 0.03)+ freqMod =+ evalState+ (PCS.bendWheelPressure 2 0.04 0.03)++ arrange <- SigStL.makeArranger+ amp <-+ CausalP.runStorableChunky+ (CausalP.envelopeStereo $<+ Instr.piecewiseConstantVector (arr id))+ return+ (\chan pgm -> do+ volume <-+ PC.controllerExponential chan+ controllerVolume+ (0.001, 1) 0.2++ ctrls <- PCS.fromChannel chan++ fmap (amp volume) $+ Gen.sequenceModulatedMultiProgram+ (arrange vectorChunkSize) ctrls chan pgm+ ([tnc, fnd, pngFM, flt, bel, ben, sqr, brs,+ ssh, fms, css, asn, atr, asq, asw, wnp] +++ map (.freqMod) tmt0 +++ map (.freqMod) hal0 +++ map (.freqMod) grp0 +++ [str, wnd, png, rfm, tin, tnb]))+++keyboardDetuneFM :: IO ()+keyboardDetuneFM = do+ proc <- keyboardDetuneFMCore+ withMIDIEventsStereo play $+ evalState (proc channel (VoiceMsg.toProgram 0))++keyboardFilter :: IO ()+keyboardFilter = do+ proc <- keyboardDetuneFMCore+ mix <- CausalP.runStorableChunky+ (CausalP.mixStereo <<< first (CausalPS.amplifyStereo 0.5)+ $< SigP.fromStorableVectorLazy (arr id))++ lowpass0 <-+ CausalP.runStorableChunky $+-- CausalPS.amplifyStereo 0.1 <<<+ CausalPS.pack+ (CausalP.stereoFromMonoControlled+ (UniFilter.lowpass ^<< UniFilterL.causalP) $<+ (SigP.interpolateConstant $# (fromIntegral vectorSize :: Real))+ (piecewiseConstant (arr id)))+ let lowpass ::+ PC.T Real -> PC.T Real ->+ SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)+ lowpass resons freqs =+ lowpass0 (fmap UniFilter.parameter+ (PC.zipWith FiltR.Pole resons (fmap (/sampleRate) freqs)))++ withMIDIEventsStereo (playAndRecord "/gentoo/server-llvm.f32") $+-- withMIDIEventsStereo play $+ evalState+ (do {-+ It is important to retrieve the global controllers+ before they are filtered out by PCS.fromChannel.+ -}+ let altChannel = (ChannelMsg.toChannel 1)+ freq <-+ PC.controllerExponential altChannel+ controllerFilterCutoff+ (100, 5000) 5000+ resonance <-+ PC.controllerExponential altChannel+ controllerFilterResonance+ (1, 100) 1+ filterMusic <- proc altChannel (VoiceMsg.toProgram 8)+ pureMusic <- proc channel (VoiceMsg.toProgram 0)+ return+ (pureMusic `mix`+ lowpass resonance freq filterMusic))
+ src/Synthesizer/LLVM/Server/Packed/Test.hs view
@@ -0,0 +1,680 @@+module Synthesizer.LLVM.Server.Packed.Test where++import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr+import Synthesizer.LLVM.Server.Packed.Instrument+ (Vector, vectorChunkSize,+ sampleStart, sampleLength,+ sampleLoopStart, sampleLoopLength,+ samplePositions, sampleData, samplePeriod, )+import Synthesizer.LLVM.Server.Common++import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC+import qualified Synthesizer.Generic.ALSA.MIDI as Gen++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, )++import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import qualified Synthesizer.LLVM.Sample as Sample+import Synthesizer.LLVM.CausalParameterized.Process (($*), )++import qualified LLVM.Core as LLVM++import qualified Synthesizer.Storable.Cut as CutSt+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SVP+import qualified Data.StorableVector.Lazy as SVL+-- import qualified Data.StorableVector as SV++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Data.EventList.Relative.BodyTime as EventListBT++import Control.Arrow ((<<<), (&&&), arr, )+import Control.Applicative (pure, liftA, liftA2, )+import Control.Monad.Trans.State (evalState, )++import Data.Tuple.HT (mapPair, )++{-+import qualified Numeric.NonNegative.Class as NonNeg+-}+import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky as NonNegChunky++{-+import qualified Algebra.RealRing as RealRing+import qualified Algebra.Additive as Additive+-}++-- import NumericPrelude.Numeric (zero, round, (^?), )+import Prelude hiding (Real, round, break, )+++{- |+try to reproduce a space leak+-}+sequencePlain :: IO ()+sequencePlain =+ SVL.writeFile "test.f32" $+-- print $ last $ SVL.chunks $+ evalState (Gen.sequence (CutSt.arrange chunkSize) channel (error "no sound" :: Instrument Real Real)) $+ let evs = EventList.cons 10 [] evs+ in evs++sequenceLLVM :: IO ()+sequenceLLVM = do+ arrange <- SigStL.makeArranger+ SVL.writeFile "test.f32" $+-- print $ last $ SVL.chunks $+ evalState (Gen.sequence (arrange vectorChunkSize) channel (error "no sound" :: Instrument Real Vector)) $+ let evs = EventList.cons 10 [] evs+ in evs++sequencePitchBendCycle :: IO ()+sequencePitchBendCycle = do+ arrange <- SigStL.makeArranger+ SVL.writeFile "test.f32" $+ evalState+ (let -- fm = error "undefined pitch bend"+ fm = EventListBT.cons 1 10 fm+ in Gen.sequenceModulated (arrange vectorChunkSize) fm channel+ (error "no sound" ::+ PC.T Real -> Instrument Real Vector)) $+ let evs = EventList.cons 10 [] evs+ in evs++sequencePitchBendSimple :: IO ()+sequencePitchBendSimple = do+ arrange <- SigStL.makeArranger+ SVL.writeFile "test.f32" $+ evalState+ (let fm y = EventListBT.cons y 10 (fm (2-y))+ in Gen.sequenceModulated (arrange vectorChunkSize) (fm 1) channel+ (error "no sound" ::+ PC.T Real -> Instrument Real Vector)) $+ let evs = EventList.cons 10 [] evs+ in evs++sequencePitchBend :: IO ()+sequencePitchBend = do+ arrange <- SigStL.makeArranger+ SVL.writeFile "test.f32" $+ evalState+ (do fm <- PC.pitchBend channel 2 0.01+ Gen.sequenceModulated (arrange vectorChunkSize) fm channel+ (error "no sound" ::+ PC.T Real -> Instrument Real Vector)) $+ let evs = EventList.cons 10 [] evs+ in evs++sequenceModulated :: IO ()+sequenceModulated = do+ arrange <- SigStL.makeArranger+ SVL.writeFile "test.f32" $+ evalState+ (do fm <- PC.bendWheelPressure channel 2 0.04 0.03+ Gen.sequenceModulated (arrange vectorChunkSize) fm channel+ (error "no sound" ::+ PC.T (MIDIL.BendModulation Real) ->+ Instrument Real Vector)) $+ let evs = EventList.cons 10 [] evs+ in evs++sequenceModulatedLong :: IO ()+sequenceModulatedLong = do+ arrange <- SigStL.makeArranger+-- sound <- Instr.softStringReleaseEnvelope+ sound <- Instr.softString -- space leak+-- sound <- Instr.pingReleaseEnvelope $/ 1 -- no space leak+-- sound <- Instr.pingRelease $/ 1 $/ 1 -- no space leak+ SVL.writeFile "test.f32" $+ evalState+ (Gen.sequence (arrange vectorChunkSize) channel sound) $+ let evs t = EventList.cons t [] (evs (20-t))+ in EventList.cons 10 [makeNote Event.NoteOn 60] $+ EventList.cons 10 [makeNote Event.NoteOn 64] $+ evs 10++sequenceModulatedLongFM :: IO ()+sequenceModulatedLongFM = do+ arrange <- SigStL.makeArranger+ sound <- Instr.softStringFM+ SVL.writeFile "test.f32" $+ evalState+ (do fm <- PC.bendWheelPressure channel 2 0.04 0.03+ Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $+ let evs t = EventList.cons t [] (evs (20-t))+ in EventList.cons 10 [makeNote Event.NoteOn 60] $+ EventList.cons 10 [makeNote Event.NoteOn 64] $+ evs 10++sequenceModulatedRepeat :: IO ()+sequenceModulatedRepeat = do+ arrange <- SigStL.makeArranger+ sound <- Instr.softStringFM+ SVL.writeFile "test.f32" $+ evalState+ (do fm <- PC.bendWheelPressure channel 2 0.04 0.03+ Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $+ let evs t =+ EventList.cons t [makeNote Event.NoteOn 60] $+ EventList.cons t [makeNote Event.NoteOff 60] $+ evs (20-t)+ in evs 10++sequencePress :: IO ()+sequencePress = do+ arrange <- SigStL.makeArranger+-- sound <- Instr.softString+-- sound <- Instr.softStringReleaseEnvelope+ sound <- Instr.pingReleaseEnvelope $/ 1+ SVL.writeFile "test.f32" $+ evalState+ (do Gen.sequence (arrange vectorChunkSize) channel sound) $+ let evs t =+ EventList.cons t [makeNote Event.NoteOn 60] $+ EventList.cons t [makeNote Event.NoteOff 60] $+ evs (20-t)+ in evs 10+++sampledSoundTest0 ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundTest0 =+ liftA+ (\osc smp _fm _vel _freq _dur ->+ osc chunkSize (sampleData smp))+ (SigP.runChunky+ (let smp = arr id+ in fmap (\x -> Stereo.cons x x) $+ SigPS.pack $+ SigP.fromStorableVectorLazy smp))++sampledSoundTest1 ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundTest1 =+ liftA+ (\osc smp _fm _vel _freq _dur ->+ osc chunkSize (sampleData smp))+ (SigP.runChunky+ (let smp = arr id+ in CausalP.stereoFromMono+ (CausalPS.pack+ (CausalP.frequencyModulationLinear+ (SigP.fromStorableVectorLazy smp)))+ $* SigP.zipWithSimple Sample.zipStereo+ (SigPS.constant 0.999)+ (SigPS.constant 1.001)))+-- $* (SigPS.constant $# Stereo.cons 0.999 1.001)))++sampledSoundTest2 ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundTest2 =+ liftA+ (\osc smp fm _vel freq dur ->+ let pos = samplePositions smp+ body =+ SigSt.take (sampleLength pos) $+ SigSt.drop (sampleStart pos) $+ sampleData smp+ in SVP.take (chunkSizesFromLazyTime dur) $+ osc chunkSize (body, (fm, freq * samplePeriod smp)))+ (SigP.runChunky+ (let smp = arr fst+ fm = arr snd+ in (CausalP.stereoFromMono+ (CausalPS.pack+ (CausalP.frequencyModulationLinear+ (SigP.fromStorableVectorLazy smp)))+ <<<+ CausalP.zipWithSimple Sample.zipStereo+ <<<+ CausalPS.amplify 0.999 &&&+ CausalPS.amplify 1.001)+ $* Instr.frequencyFromBendModulation 3 fm))++sampledSoundTest3SpaceLeak ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundTest3SpaceLeak =+ liftA+ (\osc smp _fm vel freq dur ->+ {-+ We split the frequency modulation signal+ in order to get a smooth frequency modulation curve.+ Without (periodic) frequency modulation+ we could just split the piecewise constant control curve @fm@.+ -}+ let (sustainFM, releaseFM) =+ SVP.splitAt (chunkSizesFromLazyTime dur) $+ (SigSt.repeat chunkSize+ (LLVM.vector [freq*samplePeriod smp/sampleRate])+ :: SigSt.T Vector)+ pos = samplePositions smp+ amp = 2 * amplitudeFromVelocity vel+ (attack,sustain) =+ mapPair+ (SigSt.drop (sampleStart pos),+ SigSt.take (sampleLoopLength pos)) $+ SigSt.splitAt (sampleLoopStart pos) $+ sampleData smp+ release =+ SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $+ SigSt.take (sampleStart pos + sampleLength pos) $+ sampleData smp+ in osc+ (amp,+ attack `SigSt.append`+ SVL.cycle (SigSt.take (sampleLoopLength pos) sustain))+ sustainFM+ `SigSt.append`+ osc (amp,release) releaseFM)+ (CausalP.runStorableChunky+ (let smp = arr snd+ amp = arr fst+ in CausalPS.amplifyStereo amp+ <<<+ CausalP.stereoFromMono+ (CausalPS.pack+ (CausalP.frequencyModulationLinear+ (SigP.fromStorableVectorLazy smp)))+ <<<+ CausalP.zipWithSimple Sample.zipStereo+ <<<+ CausalPS.amplify 0.999 &&&+ CausalPS.amplify 1.001))++sampledSoundTest4NoSpaceLeak ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundTest4NoSpaceLeak =+ liftA+ (\freqMod smp fm _vel freq dur ->+ {-+ We split the frequency modulation signal+ in order to get a smooth frequency modulation curve.+ Without (periodic) frequency modulation+ we could just split the piecewise constant control curve @fm@.+ -}+ let (sustainFM, releaseFM) =+ SVP.splitAt (chunkSizesFromLazyTime dur) $+ (freqMod+ (chunkSizesFromLazyTime (PC.duration fm))+ (fm, freq*samplePeriod smp) :: SigSt.T Vector)+ in SigSt.map+ (\x -> Stereo.cons x x)+ (sustainFM `SigSt.append` releaseFM))+ (SigP.runChunkyPattern+ (Instr.frequencyFromBendModulation 3 (arr id)))++sampledSoundTest5LargeSpaceLeak ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundTest5LargeSpaceLeak =+ liftA2+ (\osc freqMod smp fm vel freq dur ->+ {-+ We split the frequency modulation signal+ in order to get a smooth frequency modulation curve.+ Without (periodic) frequency modulation+ we could just split the piecewise constant control curve @fm@.+ -}+ let (sustainFM, releaseFM) =+ SVP.splitAt (chunkSizesFromLazyTime dur) $+ (freqMod+ (chunkSizesFromLazyTime (PC.duration fm))+ (fm, freq*samplePeriod smp) :: SigSt.T Vector)+ pos = samplePositions smp+ amp = 2 * amplitudeFromVelocity vel+ (attack,sustain) =+ mapPair+ (SigSt.drop (sampleStart pos),+ SigSt.take (sampleLoopLength pos)) $+ SigSt.splitAt (sampleLoopStart pos) $+ sampleData smp+ release =+ SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $+ SigSt.take (sampleStart pos + sampleLength pos) $+ sampleData smp+ in osc+ (amp,+ attack `SigSt.append`+ SVL.cycle (SigSt.take (sampleLoopLength pos) sustain))+ sustainFM+ `SigSt.append`+ osc (amp,release) releaseFM)+ (CausalP.runStorableChunky+ (arr (\x -> Stereo.cons x x)))+ (SigP.runChunkyPattern+ (Instr.frequencyFromBendModulation 3 (arr id)))+++sampledSoundSmallSpaceLeak4 ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundSmallSpaceLeak4 =+ liftA+ (\osc smp _fm _vel freq dur ->+ let (sustainFM, releaseFM) =+ SVP.splitAt (chunkSizesFromLazyTime dur) $+ (SigSt.repeat chunkSize+ (LLVM.vector [freq*samplePeriod smp/sampleRate])+ :: SigSt.T Vector)+ in osc () sustainFM+ `SigSt.append`+ SigSt.map (\x -> Stereo.cons x x) releaseFM)+ (CausalP.runStorableChunky+ (arr (\x -> Stereo.cons x x)))++sampledSoundSmallSpaceLeak4a ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundSmallSpaceLeak4a =+ liftA+ (\osc smp _fm _vel freq dur ->+ case SVP.splitAt (chunkSizesFromLazyTime dur) $+ (SigSt.repeat chunkSize+ (LLVM.vector [freq*samplePeriod smp/sampleRate])+ :: SigSt.T Vector) of+ (sustainFM, releaseFM) ->+ osc () sustainFM+ `SigSt.append`+ SigSt.map (\x -> Stereo.cons x x) releaseFM)+ (CausalP.runStorableChunky+ (arr (\x -> Stereo.cons x x)))++sampledSoundNoSmallSpaceLeak3 ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundNoSmallSpaceLeak3 =+ pure+ (\smp _fm _vel freq dur ->+ let (sustainFM, releaseFM) =+ SVP.splitAt (chunkSizesFromLazyTime dur) $+ (SigSt.repeat chunkSize+ (LLVM.vector [freq*samplePeriod smp/sampleRate])+ :: SigSt.T Vector)+ in SigSt.map (\x -> Stereo.cons x x) sustainFM+ `SigSt.append`+ SigSt.map (\x -> Stereo.cons x x) releaseFM)++{-# NOINLINE amplifySVL #-}+amplifySVL :: SVL.Vector Vector -> SVL.Vector Vector+amplifySVL = SigSt.map (2*)++sampledSoundNoSmallSpaceLeak2 ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundNoSmallSpaceLeak2 =+ liftA+ (\osc smp _fm _vel freq dur ->+ let (sustainFM, releaseFM) =+ SVP.splitAt (chunkSizesFromLazyTime dur) $+ (SigSt.repeat chunkSize+ (LLVM.vector [freq*samplePeriod smp/sampleRate])+ :: SigSt.T Vector)+ in osc ()+ (amplifySVL sustainFM+ `SigSt.append`+ amplifySVL releaseFM))+ (CausalP.runStorableChunky+ (arr (\x -> Stereo.cons x x)))++sampledSoundSmallSpaceLeak1 ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundSmallSpaceLeak1 =+ liftA+ (\osc smp _fm _vel freq dur ->+ let (sustainFM, releaseFM) =+ SVP.splitAt (chunkSizesFromLazyTime dur) $+ (SigSt.repeat chunkSize+ (LLVM.vector [freq*samplePeriod smp/sampleRate])+ :: SigSt.T Vector)+ in osc () sustainFM+ `SigSt.append`+ osc () releaseFM)+ (CausalP.runStorableChunky+ (arr (\x -> Stereo.cons x x)))++sampledSoundSmallSpaceLeak0 ::+ IO (Instr.SampledSound ->+ PC.T (PC.BendModulation Real) ->+ Instrument Real (Stereo.T Vector))+sampledSoundSmallSpaceLeak0 =+ liftA+ (\osc smp _fm vel freq dur ->+ {-+ We split the frequency modulation signal+ in order to get a smooth frequency modulation curve.+ Without (periodic) frequency modulation+ we could just split the piecewise constant control curve @fm@.+ -}+ let (sustainFM, releaseFM) =+ SVP.splitAt (chunkSizesFromLazyTime dur) $+ (SigSt.repeat chunkSize+ (LLVM.vector [freq*samplePeriod smp/sampleRate])+ :: SigSt.T Vector)+ pos = samplePositions smp+ amp = 2 * amplitudeFromVelocity vel+ (attack,sustain) =+ mapPair+ (SigSt.drop (sampleStart pos),+ SigSt.take (sampleLoopLength pos)) $+ SigSt.splitAt (sampleLoopStart pos) $+ sampleData smp+ release =+ SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $+ SigSt.take (sampleStart pos + sampleLength pos) $+ sampleData smp+ in osc+ (amp,+ attack `SigSt.append`+ SVL.cycle (SigSt.take (sampleLoopLength pos) sustain))+ sustainFM+ `SigSt.append`+ osc (amp,release) releaseFM)+ (CausalP.runStorableChunky+ (arr (\x -> Stereo.cons x x)))++++sequenceSample :: IO ()+sequenceSample = do+ arrange <- SigStL.makeArranger+ sampler <- sampledSoundTest2+ let sound =+ sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0)+ (Instr.SamplePositions 0 100000 50000 50000)+ 100)+ SVL.writeFile "test.f32" $+ evalState+ (do fm <- PC.bendWheelPressure channel 2 0.04 0.03+ Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $+ let evs t = EventList.cons t [] (evs (20-t))+ in EventList.cons 10 [makeNote Event.NoteOn 60] $+ evs 10++{-+sequenceSample1 :: IO ()+sequenceSample1 = do+ sampler <- Instr.sampledSound+ let sound =+ sampler (SampledSound (SigSt.replicate chunkSize 100000 0)+ (SamplePositions 0 100000 50000 50000)+ 100)+ SVL.writeFile "test.f32" $+ sound+{-+ (let evs f =+ EventListBT.cons (MIDIL.BendModulation 0.001 f) 10 (evs (0.02-f))+ in evs 0.01)+-}+ (let evs t =+ EventListBT.cons (MIDIL.BendModulation 0.01 0.001) t (evs (20-t))+ in evs 10)+{-+ (PCS.Cons+ (Map.singleton+ (PC.Controller VoiceMsg.modulation) 1)+ (let evs t = EventList.cons t [] (evs (20-t))+ in EventListMT.consTime 10 $ evs 10))+-}+ 0.01 1+-- (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10)+ (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10)+-}++sequenceSample1 :: IO ()+sequenceSample1 = do+ sampler <- sampledSoundSmallSpaceLeak4a+ let sound =+ sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0)+ (Instr.SamplePositions 0 100000 50000 50000)+ 100)+ SVL.writeFile "test.f32" $+ sound+ (let evs = EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 1 evs+ in evs)+ 0.01 1+ (NonNegChunky.fromChunks $ repeat $ NonNegW.fromNumber 10)++{-+sequenceSample1a :: IO ()+sequenceSample1a = do+{-+ makeStereoLLVM <-+ CausalP.runStorableChunky2 -- NoSpaceLeak+ (arr (\x -> Stereo.cons x x))+ let stereoLLVM = makeStereoLLVM ()+-}+ stereoLLVM <- CausalP.runStorableChunky3+ let stereoPlain = SigSt.map (\x -> Stereo.cons x x)+ SVL.writeFile "test.f32" $+ let dur = NonNegChunky.fromChunks $ repeat $ SVL.chunkSize 10+ !(sustainFM, releaseFM) =+ SVP.splitAt dur $+ (SigSt.repeat chunkSize (LLVM.vector [1])+ :: SigSt.T Vector)+ in case 3::Int of+ -- no leak+ 0 -> stereoLLVM $ sustainFM `SigSt.append` releaseFM+ -- no leak+ 1 -> stereoPlain $ sustainFM `SigSt.append` releaseFM+ -- no leak+ 2 -> stereoPlain sustainFM `SigSt.append` stereoPlain releaseFM+ -- leak+ 3 -> stereoLLVM sustainFM `SigSt.append` stereoPlain releaseFM+ -- no leak+ 4 -> stereoPlain sustainFM `SigSt.append` stereoLLVM releaseFM+ -- leak+ 5 -> stereoLLVM sustainFM `SigSt.append` stereoLLVM releaseFM+-}++sequenceSample2 :: IO ()+sequenceSample2 = do+ arrange <- SigStL.makeArranger+ sampler <- sampledSoundTest2+ let sound =+ sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0)+ (Instr.SamplePositions 0 100000 50000 50000)+ 100)+ SVL.writeFile "test.f32" $+ evalState+ (do bend <- PC.pitchBend channel 2 0.01+ let fm = fmap (\t -> MIDIL.BendModulation t t) bend+ Gen.sequenceModulated (arrange vectorChunkSize) fm channel sound) $+ let evs t = EventList.cons t [] (evs (20-t))+ in EventList.cons 10 [makeNote Event.NoteOn 60] $+ evs 10++{-+Interestingly, when the program aborts because of heap exhaustion,+then the generated file has size 137MB independent of the heap size+(I tried sizes from 1MB to 64MB).+-}+sequenceSample3 :: IO ()+sequenceSample3 = do+ arrange <- SigStL.makeArranger+ sampler <- sampledSoundTest2+ let sound =+ sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0)+ (Instr.SamplePositions 0 100000 50000 50000)+ 100)+ SVL.writeFile "test.f32" $+ evalState+ (let evs =+ EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 10 evs+ in Gen.sequence (arrange vectorChunkSize) channel (sound evs)) $+ let evs = EventList.cons 10 [] evs+ in EventList.cons 10 [makeNote Event.NoteOn 60] evs++sequenceSample4 :: IO ()+sequenceSample4 = do+ arrange <- SigStL.makeArranger+ sampler <- Instr.sampledSound+-- sampler <- sampledSoundTest2+ let sound =+ sampler (Instr.SampledSound (SigSt.replicate chunkSize 100000 0)+ (Instr.SamplePositions 0 100000 50000 50000)+ 100)+ SVL.writeFile "test.f32" $+ evalState+ (let evs =+ EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 10 evs+ in Gen.sequenceCore+ (arrange vectorChunkSize) channel Gen.errorNoProgram+ (Gen.Modulator () return+ (return . Gen.renderInstrumentIgnoreProgram (sound evs)))) $+ let evs = EventList.cons 10 [] evs+ in EventList.cons 10 [makeNote Event.NoteOn 60] evs++sequenceFM1 :: IO ()+sequenceFM1 = do+ arrange <- SigStL.makeArranger+ sound <- Instr.softStringFM $/+ let evs =+ EventListBT.cons (MIDIL.BendModulation 0.01 0.001) 10 evs+ in evs+-- sound <- Instr.softStringReleaseEnvelope+ SVL.writeFile "test.f32" $+ evalState+ (Gen.sequenceCore+ (arrange vectorChunkSize) channel Gen.errorNoProgram+ (Gen.Modulator () return+ (return . Gen.renderInstrumentIgnoreProgram sound))) $+ let evs = EventList.cons 10 [] evs+ in EventList.cons 10 [makeNote Event.NoteOn 60] evs+{-+ sound+ 0.01 1+ (NonNegChunky.fromChunks $ map NonNegW.fromNumber $ iterate (20-) 10)+-}+++adsr :: IO ()+adsr = do+ env <- Instr.adsr+ SVL.writeFile "adsr.f32" $+ env 0.2 2 0.15 0.3 0.5 (-0.5) 88200
+ src/Synthesizer/LLVM/Server/Scalar/Instrument.hs view
@@ -0,0 +1,199 @@+module Synthesizer.LLVM.Server.Scalar.Instrument where++import Synthesizer.LLVM.Server.Common++import qualified Synthesizer.EventList.ALSA.MIDI as Ev++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, )++import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Wave as WaveL+import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), )+import Synthesizer.LLVM.Parameterized.Signal (($#), )++import qualified LLVM.Core as LLVM++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SigStV+import qualified Data.StorableVector.Lazy as SVL++import Control.Arrow ((<<<), (^<<), (&&&), arr, )+import Control.Applicative (pure, liftA, liftA2, )++import qualified Algebra.RealRing as RealRing+import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric (zero, round, )+import Prelude hiding (Real, round, break, )+++pingSig :: SigP.T (Real, Real) (LLVM.Value Real)+pingSig =+ let vel = arr fst+ freq = arr snd+ in CausalP.envelope+ $< SigP.exponential2 (pure (0.2*sampleRate))+ (fmap amplitudeFromVelocity vel)+ $* SigP.osciSimple WaveL.saw zero (freq/sampleRate)++ping :: IO (Real -> Real -> SigSt.T Real)+ping =+ fmap curry $ fmap ($chunkSize) $ SigP.runChunky pingSig++pingDur :: IO (Instrument Real Real)+pingDur =+ fmap+ (\sound vel freq dur ->+ sound (chunkSizesFromLazyTime dur) (vel, freq)) $+ SigP.runChunkyPattern pingSig++pingDurTake :: IO (Instrument Real Real)+pingDurTake =+ fmap (\sound vel freq dur ->+ SigStV.take (chunkSizesFromLazyTime dur) $+ sound vel freq) ping++dummy :: Instrument Real Real+dummy =+ \vel freq dur ->+ SigStV.take (chunkSizesFromLazyTime dur) $+ SigSt.repeat chunkSize (vel + 1e-3*freq)++++pingReleaseEnvelope ::+ IO (Real -> Real -> Real -> Ev.LazyTime -> SigSt.T Real)+pingReleaseEnvelope =+ liftA2+ (\pressed release decay rel vel dur ->+ SigStL.continue+ (pressed (chunkSizesFromLazyTime dur) (decay,vel))+ (\x -> release chunkSize (rel,x)))+ (SigP.runChunkyPattern $+ let decay = arr fst+ velocity = arr snd+ in SigP.exponential2 (decay*sampleRate)+ (amplitudeFromVelocity ^<< velocity))+ (SigP.runChunky $+ let release = arr fst+ amplitude = arr snd+ in (CausalP.take (round ^<< (release*3*sampleRate)) $*+ SigP.exponential2 (release*sampleRate) amplitude))++pingRelease :: IO (Real -> Real -> Instrument Real Real)+pingRelease =+ liftA2+ (\osc env dec rel vel freq dur ->+ osc freq (env dec rel vel dur))+ (CausalP.runStorableChunky+ (let freq = arr id+ in CausalP.envelope $>+ SigP.osciSimple WaveL.saw zero (freq/sampleRate)))+ pingReleaseEnvelope++pingStereoRelease :: IO (Real -> Real -> Instrument Real (Stereo.T Real))+pingStereoRelease =+ liftA2+ (\osc env dec rel vel freq dur ->+ osc freq (env dec rel vel dur))+ (CausalP.runStorableChunky+ (let freq = arr id+ in CausalP.envelopeStereo $>+ SigP.zipWithSimple Sample.zipStereo+ (SigP.osciSimple WaveL.saw zero+ (0.999*freq/sampleRate))+ (SigP.osciSimple WaveL.saw zero+ (1.001*freq/sampleRate))))+ pingReleaseEnvelope++++tine :: IO (Real -> Real -> Instrument Real Real)+tine =+ liftA2+ (\osc env dec rel vel freq dur ->+ osc (vel,freq) (env dec rel 0 dur))+ (CausalP.runStorableChunky+ (let freq = arr snd+ vel = arr fst+ in CausalP.envelope $>+ (CausalP.osciSimple WaveL.approxSine2+ $> (SigP.constant (freq/sampleRate))+ $* (CausalP.envelope+ $< SigP.exponential2 (1*sampleRate) (vel+1)+ $* SigP.osciSimple WaveL.approxSine2 zero+ (2*freq/sampleRate)))))+ pingReleaseEnvelope++tineStereo :: IO (Real -> Real -> Instrument Real (Stereo.T Real))+tineStereo =+ liftA2+ (\osc env dec rel vel freq dur ->+ osc (vel,freq) (env dec rel 0 dur))+ (CausalP.runStorableChunky+ (let freq = arr snd+ vel = arr fst+ chanOsci d =+ CausalP.osciSimple WaveL.approxSine2+ $> SigP.constant (freq*d/sampleRate)+ in CausalP.envelopeStereo $>+ ((CausalP.zipWithSimple Sample.zipStereo <<<+ chanOsci 0.995 &&& chanOsci 1.005)+ $* SigP.envelope+ (SigP.exponential2 (1*sampleRate) (vel+1))+ (SigP.osciSimple WaveL.approxSine2 zero+ (2*freq/sampleRate)))))+ pingReleaseEnvelope++++softStringReleaseEnvelope ::+ IO (Real -> Ev.LazyTime -> SigSt.T Real)+softStringReleaseEnvelope =+ let attackTime = sampleRate+ in liftA+ (\env vel dur ->+ let amp = amplitudeFromVelocity vel+ {-+ release <- take attackTime beginning+ would yield a space leak, thus we first split 'beginning'+ and then concatenate it again+ -}+ {-+ We can not easily generate attack and sustain separately,+ because we want to use the chunk structure implied by 'dur'.+ -}+ (attack, sustain) =+ SigSt.splitAt attackTime $+ env (chunkSizesFromLazyTime dur) amp+ release = SigSt.reverse attack+ in attack `SigSt.append` sustain `SigSt.append` release)+ (let amp = arr id+ in SigP.runChunkyPattern $+ flip SigP.append (SigP.constant amp) $+ SigP.amplify amp $+ (SigP.parabolaFadeIn $# fromIntegral attackTime))++softString :: IO (Instrument Real (Stereo.T Real))+softString =+ liftA2+ (\osc env vel freq dur ->+ osc freq (env vel dur))+ (let freq = arr id+ osci d =+ SigP.osciSimple WaveL.saw zero (d * freq / sampleRate)+ in CausalP.runStorableChunky $+ (CausalP.envelopeStereo $>+ (SigP.zipWithSimple Sample.zipStereo+ (SigP.mix+ (osci 1.005)+ (osci 0.998))+ (SigP.mix+ (osci 1.002)+ (osci 0.995)))))+ softStringReleaseEnvelope
+ src/Synthesizer/LLVM/Server/Scalar/Run.hs view
@@ -0,0 +1,123 @@+module Synthesizer.LLVM.Server.Scalar.Run where++import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr+import Synthesizer.LLVM.Server.Common++import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Data.EventList.Relative.TimeBody as EventList++import qualified Synthesizer.EventList.ALSA.MIDI as Ev+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC+import qualified Synthesizer.Generic.ALSA.MIDI as Gen++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+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.Parameterized.Signal (($#), )++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as SVL++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import Control.Arrow ((<<<), arr, )+import Control.Monad.Trans.State (evalState, )++import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric (zero, (*>), )+import Prelude hiding (Real, break, )+++{-# INLINE withMIDIEvents #-}+withMIDIEvents ::+ (Double -> Double -> a -> IO b) ->+ (EventList.T Ev.StrictTime [Event.T] -> a) -> IO b+withMIDIEvents action proc =+ let rate = sampleRate+ per = periodTime+ in Ev.withMIDIEvents per rate $+ action per rate . proc++++pitchBend :: IO ()+pitchBend = do+ osc <-+ SigP.runChunky+ ((CausalP.osciSimple WaveL.triangle $<# (zero::Real))+ $* piecewiseConstant (arr id))+ withMIDIEvents play $+ (id :: SigSt.T Real -> SigSt.T Real) .+ osc chunkSize .+ evalState (PC.pitchBend channel 2 (880/sampleRate::Real))+++frequencyModulation :: IO ()+frequencyModulation = do+ osc <-+ SigP.runChunky+ (((CausalP.osciSimple WaveL.triangle $<# (zero::Real))+ <<< (MIDIL.frequencyFromBendModulation $# (10/sampleRate::Real)))+ $* piecewiseConstant (arr (transposeModulation 880)))+ withMIDIEvents play $+ (id :: SigSt.T Real -> SigSt.T Real) .+ osc chunkSize .+ evalState (PC.bendWheelPressure channel 2 0.04 (0.03::Real))++++keyboard :: IO ()+keyboard = do+-- sound <- Instr.pingDur+{-+ sound <-+ fmap (\s vel _freq dur -> s vel dur) $+ (Instr.pingReleaseEnvelope $/ 0.4 $/ 0.1)+-}+ sound <- Instr.pingRelease $/ 0.4 $/ 0.1+ amp <- CausalP.runStorableChunky (CausalP.amplify $# 0.2)+ arrange <- SigStL.makeArranger+ withMIDIEvents play $+ (amp () :: SigSt.T Real -> SigSt.T Real) .+ evalState (Gen.sequence (arrange chunkSize) channel sound)++keyboardStereo :: IO ()+keyboardStereo = do+ sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1+ amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2)+ arrange <- SigStL.makeArranger+ withMIDIEvents play $+ (amp () :: SigSt.T (Stereo.T Real) -> SigSt.T (Stereo.T Real)) .+ evalState (Gen.sequence (arrange chunkSize) channel sound)++keyboardMulti :: IO ()+keyboardMulti = do+ png <- Instr.pingDur+ pngRel <- Instr.pingRelease $/ 0.4 $/ 0.1+ tin <- Instr.tine $/ 0.4 $/ 0.1+ arrange <- SigStL.makeArranger+ withMIDIEvents play $+-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .+ SigSt.map (0.2*) .+ evalState (Gen.sequenceMultiProgram (arrange chunkSize) channel+ (VoiceMsg.toProgram 2)+ [png, pngRel, tin])++keyboardStereoMulti :: IO ()+keyboardStereoMulti = do+ png <- Instr.pingStereoRelease $/ 0.4 $/ 0.1+ tin <- Instr.tineStereo $/ 0.4 $/ 0.1+ str <- Instr.softString+ arrange <- SigStL.makeArranger+ withMIDIEvents play $+-- playALSA (Bld.put :: Int16 -> Bld.Builder Int16) (sampleRate::Real) .+ SigSt.map ((0.2::Real)*>) .+ evalState (Gen.sequenceMultiProgram (arrange chunkSize) channel+ (VoiceMsg.toProgram 1)+ [png, tin, str])
+ src/Synthesizer/LLVM/Server/Scalar/Test.hs view
@@ -0,0 +1,78 @@+module Synthesizer.LLVM.Server.Scalar.Test where++import qualified Synthesizer.LLVM.Server.Scalar.Instrument as Instr+import Synthesizer.LLVM.Server.Scalar.Run (withMIDIEvents, )+import Synthesizer.LLVM.Server.Common++import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC+import qualified Synthesizer.Generic.ALSA.MIDI as Gen++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 qualified Synthesizer.Storable.Cut as CutSt+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as SVL++import qualified Data.EventList.Relative.TimeBody as EventList++import Control.Arrow (arr, )+import Control.Monad.Trans.State (evalState, )++import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric (zero, )+import Prelude hiding (Real, )+++pitchBend0 :: IO ()+pitchBend0 = do+ osc <-+ SigP.runChunky+ ((CausalP.osciSimple WaveL.triangle $<# (zero::Real))+ $* piecewiseConstant (arr id))+ SVL.writeFile "test.f32" $+ (id :: SigSt.T Real -> SigSt.T Real) .+ osc chunkSize .+ evalState (PC.pitchBend channel 2 (880/sampleRate::Real)) $+ let evs = EventList.cons 100 [] evs+ in EventList.cons 0 [] evs++pitchBend1 :: IO ()+pitchBend1 = do+ osc <-+ SigP.runChunky+ ((CausalP.osciSimple WaveL.triangle $<# (zero::Real))+ $* piecewiseConstant (arr id))+ withMIDIEvents (\ _period _rate -> SVL.writeFile "test.f32") $+ (id :: SigSt.T Real -> SigSt.T Real) .+ osc chunkSize .+ evalState (PC.pitchBend channel 2 (880/sampleRate::Real))++pitchBend2 :: IO ()+pitchBend2 =+ withMIDIEvents (\ _period _rate -> print) id++++sequencePress :: IO ()+sequencePress = do+-- arrange <- SigStL.makeArranger+-- sound <- Instr.softString+-- sound <- Instr.softStringReleaseEnvelope+-- sound <- Instr.pingReleaseEnvelope $/ 1+-- sound <- Instr.pingDur+-- sound <- Instr.pingDurTake+ let sound = Instr.dummy+ SVL.writeFile "test.f32" $+ evalState+ (do Gen.sequence (CutSt.arrange chunkSize) channel sound) $+ let evs t =+ EventList.cons t [makeNote Event.NoteOn 60] $+ EventList.cons t [makeNote Event.NoteOff 60] $+ evs (20-t)+ in evs 10+
+ src/Synthesizer/LLVM/Simple/Signal.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Synthesizer.LLVM.Simple.Signal where++import qualified LLVM.Extra.Representation as Rep+import qualified Synthesizer.LLVM.Wave as Wave+import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Execution as Exec+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.MaybeContinuation as Maybe++import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import qualified Data.StorableVector.Base as SVB++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )+import LLVM.Extra.Control (whileLoop, ifThen, )++import LLVM.Core+import LLVM.Util.Loop (Phi, )++import Control.Monad (liftM2, liftM3, )++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring++import Data.Word (Word32, )+import Foreign.Storable.Tuple ()+import Foreign.Storable (Storable, )+import Foreign.Marshal.Array (advancePtr, )+import qualified Foreign.Marshal.Array as Array+import qualified Foreign.Marshal.Alloc as Alloc+import Foreign.ForeignPtr+ (unsafeForeignPtrToPtr, touchForeignPtr, withForeignPtr, )+import Foreign.Ptr (FunPtr, nullPtr, )+import Control.Exception (bracket, )+import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )+++{-+We need the forall quantification for 'CodeGenFunction's @r@ parameter.+This type parameter will be unified with the result type of the final function.+Since one piece of code can be used in multiple functions+we cannot yet fix the type @r@ here.++We might avoid code duplication by defining++> newtype T a = Cons (Causal.T () a)+-}+data T a =+ forall state packed size ioContext.+ (Rep.Memory state packed, IsSized packed size) =>+ Cons (forall r c.+ (Phi c) =>+ ioContext ->+ state -> Maybe.T r c (a, state))+ -- compute next value+ (forall r.+ ioContext ->+ CodeGenFunction r state)+ -- initial state+ (IO ioContext)+ {- initialization from IO monad+ This will be run within unsafePerformIO,+ so no observable In/Out actions please!+ -}+ (ioContext -> IO ())+ -- finalization from IO monad, also run within unsafePerformIO++simple ::+ (Rep.Memory state packed, IsSized packed size) =>+ (forall r c.+ state -> Maybe.T r c (a, state)) ->+ (forall r. CodeGenFunction r state) ->+ T a+simple next start =+ Cons+ (const next)+ (const start)+ (return ())+ (const $ return ())+++map ::+ (forall r. a -> CodeGenFunction r b) -> T a -> T b+map f (Cons next start createIOContext deleteIOContext) =+ Cons+ (\ioContext sa0 -> do+ (a,sa1) <- next ioContext sa0+ b <- Maybe.lift $ f a+ return (b, sa1))+ start+ createIOContext deleteIOContext++mapAccum ::+ (Rep.Memory s struct, IsSized struct sa) =>+ (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+ (\ioContext (sa0,ss0) -> do+ (a,sa1) <- next ioContext sa0+ (b,ss1) <- Maybe.lift $ f a ss0+ return (b, (sa1,ss1)))+ (\ioContext ->+ liftM2 (,) (start ioContext) startS)+ createIOContext deleteIOContext+++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) =+ Cons+ (\(ioContextA, ioContextB) (sa0,sb0) -> do+ (a,sa1) <- nextA ioContextA sa0+ (b,sb1) <- nextB ioContextB sb0+ c <- Maybe.lift $ f a b+ return (c, (sa1,sb1)))+ (\(ioContextA, ioContextB) ->+ liftM2 (,)+ (startA ioContextA)+ (startB ioContextB))+ (liftM2 (,)+ createIOContextA+ createIOContextB)+ (\(ca,cb) ->+ deleteIOContextA ca >>+ deleteIOContextB cb)++zip ::+ T a -> T b -> T (a,b)+zip = zipWith (\a b -> return (a,b))+++{- |+Stretch signal in time by a certain factor.+-}+interpolateConstant ::+ (Rep.Memory a struct, IsSized struct size,+ Ring.C b,+ IsFloating b, CmpRet b Bool,+ IsConst b, IsFirstClass b, IsSized b sb) =>+ b -> T a -> T a+interpolateConstant k+ (Cons next start createIOContext deleteIOContext) =+ Cons+ (\ioContext ((y0,state0),ss0) ->+ do ((y1,state1), ss1) <-+ Maybe.fromBool $+ whileLoop+ (valueOf True, ((y0,state0), ss0))+ (\(cont1, (_, ss1)) ->+ and cont1 =<< A.fcmp FPOLE ss1 (valueOf 0))+ (\(_, ((_,state01), ss1)) ->+ Maybe.toBool $ liftM2 (,)+ (next ioContext state01)+ (Maybe.lift $ A.add ss1 (valueOf k)))++ ss2 <- Maybe.lift $ A.sub ss1 (valueOf Ring.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, valueOf 0))+-}+ (fmap (\sa -> ((undefTuple, sa), valueOf 0)) . start)+ createIOContext deleteIOContext+++mix ::+ (IsArithmetic a) =>+ T (Value a) -> T (Value a) -> T (Value a)+mix = zipWith Sample.mixMono++mixStereo ::+ (IsArithmetic a) =>+ T (Stereo.T (Value a)) -> T (Stereo.T (Value a)) -> T (Stereo.T (Value a))+mixStereo = zipWith Sample.mixStereo+++envelope ::+ (IsArithmetic a) =>+ T (Value a) -> T (Value a) -> T (Value a)+envelope = zipWith Sample.amplifyMono++envelopeStereo ::+ (IsArithmetic a) =>+ T (Value a) -> T (Stereo.T (Value a)) -> T (Stereo.T (Value a))+envelopeStereo = zipWith Sample.amplifyStereo++amplify ::+ (IsArithmetic a, IsConst a) =>+ a -> T (Value a) -> T (Value a)+amplify x =+ map (Sample.amplifyMono (valueOf x))++amplifyStereo ::+ (IsArithmetic a, IsConst a) =>+ a -> T (Stereo.T (Value a)) -> T (Stereo.T (Value a))+amplifyStereo x =+ map (Sample.amplifyStereo (valueOf x))++++iterate ::+ (IsFirstClass a, IsSized a s, IsConst a) =>+ (forall r. Value a -> CodeGenFunction r (Value a)) ->+ Value a -> T (Value a)+iterate f initial =+ simple+ (\y -> Maybe.lift $ fmap (\y1 -> (y,y1)) (f y))+ (return initial)++exponential2 ::+ (Trans.C a,+ IsFirstClass a, IsSized a s, IsArithmetic a, IsConst a) =>+ a -> a -> T (Value a)+exponential2 halfLife =+ iterate (\y -> A.mul y (valueOf (0.5 ** recip halfLife))) . valueOf+++osciPlain ::+ (IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t) =>+ (forall r. Value t -> CodeGenFunction r y) ->+ Value t -> Value t -> T y+osciPlain wave phase freq =+ map wave $+ iterate (SoV.incPhase freq) $+ phase++osci ::+ (IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t) =>+ (forall r. Value t -> CodeGenFunction r y) ->+ t -> t -> T y+osci wave phase freq =+ osciPlain wave (valueOf phase) (valueOf freq)++osciSaw ::+ (Ring.C a0, IsConst a0, SoV.Replicate a0 a,+ IsFirstClass a, IsSized a size,+ SoV.Fraction a, IsConst a) =>+ a -> a -> T (Value a)+osciSaw = osci Wave.saw++++fromStorableVector ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ SV.Vector a ->+ T value+fromStorableVector xs =+ let (fp,s,l) = SVB.toForeignPtr xs+ in Cons+ (\_ (p0,l0) -> do+ cont <- Maybe.lift $ A.icmp IntUGT l0 (valueOf 0)+ Maybe.withBool cont $ do+ y1 <- Rep.load p0+ p1 <- advanceArrayElementPtr p0+ l1 <- A.dec l0+ return (y1,(p1,l1)))+ (const $ return+ (valueOf (Rep.castStorablePtr $ unsafeForeignPtrToPtr fp `advancePtr` s),+ valueOf (fromIntegral l :: Word32)))+ -- keep the foreign ptr alive+ (return fp)+ touchForeignPtr++{-+This function calls back into the Haskell function 'nextChunk'+that returns a pointer to the data of the next chunk+and advances to the next chunk in the sequence.+-}+fromStorableVectorLazy ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ SVL.Vector a ->+ T value+fromStorableVectorLazy sig =+ Cons+ (\(stable, lenPtr) (buffer0,length0) -> do+ (buffer1,length1) <- Maybe.lift $ do+ nextChunkFn <- staticFunction ChunkIt.nextCallBack+ needNext <- A.icmp IntEQ length0 (valueOf 0)+ ifThen needNext (buffer0,length0)+ (liftM2 (,)+ (call nextChunkFn (valueOf stable) (valueOf lenPtr))+ (load (valueOf lenPtr)))+ valid <- Maybe.lift $ A.icmp IntNE buffer1 (valueOf nullPtr)+ Maybe.withBool valid $ do+ x <- Rep.load buffer1+ buffer2 <- advanceArrayElementPtr buffer1+ length2 <- A.dec length1+ return (x, (buffer2,length2)))+ (const $ return (valueOf nullPtr, valueOf 0))+ (liftM2 (,) (ChunkIt.new sig) Alloc.malloc)+ (\(stable,lenPtr) -> do+ ChunkIt.dispose stable+ Alloc.free lenPtr)+++{-+compile ::+ (Rep.Memory value struct) =>+ T value ->+ CodeGenModule (Function (Word32 -> Ptr struct -> IO Word32))+-}++{-+We could also implement that in terms of getPointerToFunction+as done in Parameterized.Signal.+However, since the 'fill' function will be called only once,+it does not matter whether we use the Just-In-Time compiler+or compile once.+-}+render ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ Int -> T value -> SV.Vector a+render len (Cons next start createIOContext deleteIOContext) =+ unsafePerformIO $+ bracket createIOContext deleteIOContext $ \ ioContext ->+ SVB.createAndTrim len $ \ ptr ->+ do fill <-+ Exec.runFunction $+ createFunction ExternalLinkage $ \ size bPtr -> do+ s <- start ioContext+ (pos,_) <- Maybe.arrayLoop size bPtr s $ \ ptri s0 -> do+ (y,s1) <- next ioContext s0+ Maybe.lift $ Rep.store y ptri+ return s1+ ret (pos :: Value Word32)+ fmap (fromIntegral :: Word32 -> Int) $+ fill (fromIntegral len) (Rep.castStorablePtr ptr)+++foreign import ccall safe "dynamic" derefChunkPtr ::+ Exec.Importer (Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)+++compileChunky ::+ (Rep.Memory value struct,+ Rep.Memory state stateStruct,+ IsSized stateStruct stateSize) =>+ (forall r.+ state -> Maybe.T r (Value Bool, state) (value, state)) ->+ (forall r.+ CodeGenFunction r state) ->+ IO (FunPtr (IO (Ptr stateStruct)),+ FunPtr (Ptr stateStruct -> IO ()),+ FunPtr (Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32))+compileChunky next start =+ Exec.compileModule $+ liftM3 (,,)+ (createFunction ExternalLinkage $+ do+ -- FIXME: size computation in LLVM currently does not work for structs!+ pptr <- Rep.malloc+ flip Rep.store pptr =<< start+ ret pptr)+{- for debugging: allocation with initialization makes type inference difficult+ (createFunction ExternalLinkage $+ do+ pptr <- malloc+ let retn :: CodeGenFunction r state -> Value (Ptr state) -> CodeGenFunction (Ptr state) ()+ retn _ ptr = ret ptr+ retn undefined pptr)+-}+ (createFunction ExternalLinkage $+ \ pptr -> Rep.free pptr >> ret ())+ (createFunction ExternalLinkage $+ \ sptr loopLen ptr -> do+ sInit <- Rep.load sptr+ (pos,sExit) <- Maybe.arrayLoop loopLen ptr sInit $+ \ ptri s0 -> do+ (y,s1) <- next s0+ Maybe.lift $ Rep.store y ptri+ return s1+ Rep.store sExit sptr+ ret (pos :: Value Word32))+++runChunky ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ SVL.ChunkSize -> T value -> IO (SVL.Vector a)+runChunky (SVL.ChunkSize size)+ (Cons next start createIOContext deleteIOContext) = do+ ioContext <- createIOContext+ (startFunc, stopFunc, fill) <-+ compileChunky (next ioContext) (start ioContext)++ statePtr <- Rep.newForeignPtrInit stopFunc startFunc+ -- for explanation see Causal.Process+ ioContextPtr <- Rep.newForeignPtr (deleteIOContext ioContext) False++ let go =+ unsafeInterleaveIO $ do+ v <-+ withForeignPtr statePtr $ \sptr ->+ SVB.createAndTrim size $+ fmap (fromIntegral :: Word32 -> Int) .+ derefChunkPtr fill sptr (fromIntegral size) .+ Rep.castStorablePtr+ touchForeignPtr ioContextPtr+ (if SV.length v > 0+ then fmap (v:)+ else id) $+ (if SV.length v < size+ then return []+ else go)+ fmap SVL.fromChunks go++renderChunky ::+ (Storable a, MakeValueTuple a value, Rep.Memory value struct) =>+ SVL.ChunkSize -> T value -> SVL.Vector a+renderChunky size sig =+ unsafePerformIO (runChunky size sig)
+ src/Synthesizer/LLVM/Simple/Value.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Synthesizer.LLVM.Simple.Value where++import qualified LLVM.Extra.ScalarOrVector as SoV++import qualified LLVM.Extra.Arithmetic as A++import LLVM.Core hiding (zero, )+import qualified LLVM.Core as LLVM+import qualified LLVM.Util.Arithmetic as Arith++import qualified Synthesizer.Basic.Phase as Phase++import Control.Monad (liftM2, liftM3, )++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Algebraic as Algebraic+import qualified Algebra.RealRing as RealRing+import qualified Algebra.Module as Module+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import qualified Data.Traversable as Trav++import NumericPrelude.Numeric+import NumericPrelude.Base+++{-+The @r@ type parameter must be hidden and forall-quantified+because otherwise we would need an impossible type+where we have to quantify for @r@ and @t@ in different scopes+while having a class constraint that involves both of them.++> osci ::+> (RealRing.C (Value.T r t),+> IsFirstClass t, IsSized t size, IsFloating t,+> IsPrimitive t, IsConst t) =>+> (forall r. Wave.T (Value.T r t) (Value.T r y)) ->+> t -> t -> T (Value y)++-}+newtype T a = Cons {decons :: forall r. Arith.TValue r a}++{- |+We do not require a numeric prelude superclass,+thus also LLVM only types like vectors are instances.+-}+instance (IsArithmetic a, IsConst a) => Additive.C (T a) where+ zero = constantValue (value LLVM.zero)+ (+) = binop add+ (-) = binop sub+ negate (Cons x) = Cons (neg =<< x)++instance (Ring.C a, IsArithmetic a, IsConst a) =>+ Ring.C (T a) where+ one = constant one+ (*) = binop mul+ fromInteger = constant . fromInteger++{-+Two instance declarations are enough for Module here.+The difference to Module instances on Haskell tuples is,+that LLVM vectors cannot be nested.+-}+instance (Ring.C a, IsArithmetic a, IsConst a) =>+ Module.C (T a) (T a) where+ (*>) = (*)++instance (Ring.C a, IsArithmetic a, IsConst a, IsPrimitive a, IsPowerOf2 n) =>+ Module.C (T a) (T (Vector n a)) where+ (Cons a) *> (Cons v) = Cons (do+ a0 <- a+ a1 <- SoV.replicate a0+ A.mul a1 =<< v+ )++instance (Ring.C a, IsArithmetic a, IsConst a) => Enum (T a) where+ succ x = x + one+ pred x = x - one+ fromEnum _ = error "CodeGenFunction Value: fromEnum"+ toEnum = fromIntegral++{-+instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (T a) where+ toRational _ = error "CodeGenFunction Value: toRational"++instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (T a) where+ quot = binop (if (isSigned (undefined :: a)) then sdiv else udiv)+ rem = binop (if (isSigned (undefined :: a)) then srem else urem)+ quotRem x y = (quot x y, rem x y)+ toInteger _ = error "CodeGenFunction Value: toInteger"+-}++instance (Field.C a, IsConst a, IsFloating a) => Field.C (T a) where+ (/) = binop fdiv+ fromRational' = constant . fromRational'++{-+instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (T a) where+ properFraction _ = error "CodeGenFunction Value: properFraction"+-}++instance (Algebraic.C a, IsConst a, IsFloating a) => Algebraic.C (T a) where+ sqrt = lift1 A.sqrt++instance (Trans.C a, IsConst a, IsFloating a) => Trans.C (T a) where+ pi = constant pi+ sin = lift1 A.sin+ cos = lift1 A.cos+ (**) = lift2 A.pow+ exp = lift1 A.exp+ log = lift1 A.log++ asin _ = error "LLVM missing intrinsic: asin"+ acos _ = error "LLVM missing intrinsic: acos"+ atan _ = error "LLVM missing intrinsic: atan"++{-+ sinh x = (exp x - exp (-x)) / 2+ cosh x = (exp x + exp (-x)) / 2+ asinh x = log (x + sqrt (x*x + 1))+ acosh x = log (x + sqrt (x*x - 1))+ atanh x = (log (1 + x) - log (1 - x)) / 2+-}+++twoPi ::+ (Trans.C a, IsConst a, IsFloating a) =>+ T a+twoPi = 2*pi+{-+twoPi ::+ (Cmp a b, P.Floating a, IsConst a, IsFloating a) =>+ Arith.TValue r a+twoPi = P.fromInteger 2 P.* P.pi+-}+++lift1 ::+ (forall r. Value a -> CodeGenFunction r (Value b)) ->+ T a -> T b+lift1 f x =+ Cons $ f =<< decons x++lift2 ::+ (forall r. Value a -> Value b -> CodeGenFunction r (Value c)) ->+ T a -> T b -> T c+lift2 f x y =+ Cons $ uncurry f =<< liftM2 (,) (decons x) (decons y)+++constantValue :: Value a -> T a+constantValue x =+ Cons (return x)++constant :: (IsConst a) => a -> T a+constant = constantValue . valueOf++binop ::+ (forall r. Value a -> Value b -> Arith.TValue r c) ->+ T a -> T b -> T c+binop op x y = Cons (do+ x' <- decons x+ y' <- decons y+ op x' y')+++class Flatten value register | value -> register where+ flatten :: value -> CodeGenFunction r register+ unfold :: register -> value++flattenTraversable ::+ (Flatten value register, Trav.Traversable f) =>+ f value -> CodeGenFunction r (f register)+flattenTraversable =+ Trav.mapM flatten++unfoldFunctor ::+ (Flatten value register, Functor f) =>+ f register -> f value+unfoldFunctor =+ fmap unfold+++instance (Flatten ah al, Flatten bh bl) =>+ Flatten (ah,bh) (al,bl) where+ flatten (a,b) =+ liftM2 (,) (flatten a) (flatten b)+ unfold (a,b) =+ (unfold a, unfold b)++instance (Flatten ah al, Flatten bh bl, Flatten ch cl) =>+ Flatten (ah,bh,ch) (al,bl,cl) where+ flatten (a,b,c) =+ liftM3 (,,) (flatten a) (flatten b) (flatten c)+ unfold (a,b,c) =+ (unfold a, unfold b, unfold c)++instance Flatten v r =>+ Flatten (Stereo.T v) (Stereo.T r) where+ flatten s =+ liftM2 Stereo.cons+ (flatten $ Stereo.left s)+ (flatten $ Stereo.right s)+ unfold s =+ Stereo.cons+ (unfold $ Stereo.left s)+ (unfold $ Stereo.right s)++instance+ (RealRing.C v, Flatten v r) =>+ Flatten (Phase.T v) r where+ flatten s =+ flatten $ Phase.toRepresentative s+ unfold s =+ -- could also be unsafeFromRepresentative+ Phase.fromRepresentative $ unfold s+++instance (IsConst a) => Flatten (T a) (Value a) where+ flatten = decons+ unfold = constantValue+instance Flatten () () where+ flatten = return+ unfold = id
+ src/Synthesizer/LLVM/Simple/Vanilla.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Simple.Vanilla where++import qualified Synthesizer.LLVM.Simple.Signal as Sig+import qualified LLVM.Extra.Representation as Rep+import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.MaybeContinuation as Maybe++import qualified Synthesizer.Basic.Phase as Phase+import qualified Synthesizer.Basic.Wave as Wave++{-+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import qualified Data.StorableVector.Base as SVB+-}++-- import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import LLVM.Core++-- import Control.Monad (liftM2, liftM3, )++-- import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealRing as RealRing+-- import qualified Algebra.Field as Field+-- import qualified Algebra.Ring as Ring+-- import qualified Algebra.Additive as Additive++-- import NumericPrelude.Numeric+import NumericPrelude.Base hiding (and, iterate, map, zipWith, )+++iterateVal ::+ (IsFirstClass a, IsSized a size) =>+ (Value.T a -> Value.T a) ->+ Value.T a -> Sig.T (Value.T a)+iterateVal f initial =+ Sig.simple+ (\y ->+ Maybe.lift $+ fmap (\y1 -> (Value.constantValue y, y1))+ (Value.decons (f (Value.constantValue y))))+ (Value.decons initial)++iterate ::+ (Value.Flatten a reg, Rep.Memory reg packed, IsSized packed size) =>+ (a -> a) ->+ (a -> Sig.T a)+iterate f initial =+ Sig.simple+ (\y ->+ Maybe.lift $+ fmap (\y1 -> (Value.unfold y, y1))+ (Value.flatten (f (Value.unfold y))))+ (Value.flatten initial)++++map ::+ (a -> b) ->+ Sig.T a -> Sig.T b+map f = Sig.map (return . f)+++osciReg ::+ (RealRing.C (Value.T t),+ IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t,+ IsFirstClass y) =>+ Wave.T (Value.T t) (Value.T y) ->+ Value t -> Value t -> Sig.T (Value y)+osciReg wave phase freq =+ Sig.map+ (Value.decons . Wave.apply wave .+ Phase.fromRepresentative . Value.constantValue) $+ Sig.iterate (SoV.incPhase freq) phase++osciVal ::+ (RealRing.C (Value.T t),+ IsFirstClass t, IsSized t size,+ SoV.Fraction t, IsConst t) =>+ Wave.T (Value.T t) y ->+ Value.T t -> Value.T t -> Sig.T y+osciVal wave phase freq =+ map (Wave.apply wave . Phase.fromRepresentative) $+ iterateVal (incPhaseVal freq) phase++incPhaseVal ::+ (SoV.Fraction a, IsArithmetic a) =>+ Value.T a -> Value.T a -> Value.T a+incPhaseVal = Value.binop SoV.incPhase++osci ::+ (RealRing.C t,+ Value.Flatten t reg,+ Rep.Memory reg struct, IsSized struct size,+ SoV.Fraction t, IsConst t) =>+ Wave.T t y ->+ Phase.T t -> t -> Sig.T y+osci wave phase freq =+ map (Wave.apply wave) $+ iterate (Phase.increment freq) phase
+ src/Synthesizer/LLVM/Storable/ChunkIterator.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Synthesizer.LLVM.Storable.ChunkIterator where++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector.Base as SVB++import Data.Word (Word32, )+import Foreign.Storable (Storable, poke, )+import Foreign.Ptr (FunPtr, Ptr, nullPtr, castPtr, )++import Control.Monad (liftM2, )++import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, )+import Data.IORef (IORef, newIORef, readIORef, writeIORef, )+++data T =+ forall a. Storable a =>+ Cons (IORef [SVB.Vector a]) (IORef (SVB.Vector a))++{-+I do not see a way,+how to bind the result type @Ptr a@+to the input type @SV.Vector a@.+We cannot make the element type of the storable vector+a type parameter of 'T'+since then we would also need to make Storable+a constraint of the FFI interface,+and this is forbidden.+-}+foreign import ccall "&nextChunk"+ nextCallBack ::+ FunPtr (+ StablePtr T ->+ Ptr Word32 -> IO (Ptr a)+ )++foreign export ccall "nextChunk"+ next ::+ StablePtr T ->+ Ptr Word32 -> IO (Ptr a)+++new ::+ Storable a =>+ SVL.Vector a -> IO (StablePtr T)+new sig =+ newStablePtr =<<+ liftM2 Cons+ (newIORef (SVL.chunks sig))+ (newIORef+ (error "first chunk must be fetched with nextChunk"))++dispose ::+ StablePtr T -> IO ()+dispose = freeStablePtr++next ::+ StablePtr T ->+ Ptr Word32 -> IO (Ptr a)+next stable lenPtr =+ deRefStablePtr stable >>= \state ->+ case state of+ Cons listRef chunkRef -> do+ xt <- readIORef listRef+ case xt of+ [] -> return nullPtr+ (x:xs) ->+ {- We have to maintain a pointer to the current chunk+ in order to protect it against garbage collection -}+ writeIORef chunkRef x >>+ writeIORef listRef xs >>+ SVB.withStartPtr x (\p l ->+ poke lenPtr (fromIntegral l) >> return (castPtr p))
+ src/Synthesizer/LLVM/Storable/LazySizeIterator.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Synthesizer.LLVM.Storable.LazySizeIterator where++import qualified Numeric.NonNegative.Chunky as Chunky+import qualified Data.StorableVector.Lazy.Pattern as SVP+import qualified Data.StorableVector.Lazy as SVL++import Data.Word (Word32, )++import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, )+import Foreign.Ptr (FunPtr, )+import Data.IORef (IORef, newIORef, readIORef, writeIORef, )+import qualified Data.List.HT as ListHT+++newtype T = Cons (IORef [SVL.ChunkSize])++{-+For problems about Storable constraint, see ChunkIterator.+-}+foreign import ccall "&nextSize"+ nextCallBack ::+ FunPtr (StablePtr T -> IO Word32)++foreign export ccall "nextSize"+ next :: StablePtr T -> IO Word32+++new ::+ SVP.LazySize -> IO (StablePtr T)+new ls =+ newStablePtr . Cons =<< newIORef (Chunky.toChunks (Chunky.normalize ls))++dispose ::+ StablePtr T -> IO ()+dispose = freeStablePtr++{- |+Zero pieces are filtered out.+If 'next' returns 0 then the end of the lazy size is reached.+-}+next ::+ StablePtr T -> IO Word32+next stable =+ deRefStablePtr stable >>= \state ->+ case state of+ Cons listRef ->+ readIORef listRef >>=+ ListHT.switchL+ (return 0)+ (\(SVL.ChunkSize time) xs ->+ writeIORef listRef xs >>+ return (fromIntegral time))
+ src/Synthesizer/LLVM/Storable/Signal.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{- |+Functions on lazy storable vectors that are implemented using LLVM.+-}+module Synthesizer.LLVM.Storable.Signal (+ unpackStrict, unpack,+ makeUnpackGenericStrict, makeUnpackGeneric,+ makeReversePackedStrict, makeReversePacked,+ continue, continuePacked, continuePackedGeneric,+ makeMixer,+ makeArranger, arrange,+ ) where++import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS++import qualified Synthesizer.LLVM.Execution as Exec+import qualified Synthesizer.LLVM.Sample as Sample+import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Extra.Vector as Vector+import LLVM.Extra.Control (arrayLoop, )++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import qualified Data.StorableVector.Base as SVB++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Data.EventList.Relative.TimeMixed as EventListTM+import qualified Data.EventList.Absolute.TimeBody as AbsEventList+import qualified Number.NonNegative as NonNeg++import qualified Algebra.Additive as Additive++import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )++import LLVM.Core+ (Linkage(ExternalLinkage), createFunction, ret,+ MakeValueTuple, IsSized, IsPrimitive, getElementPtr,+ Vector, IsPowerOf2, )+import qualified Data.TypeLevel.Num as TypeNum++import qualified Control.Category as Cat++import qualified Data.List.HT as ListHT+import Data.Word (Word32, )+import Data.Int (Int32, )+import Foreign.Ptr (Ptr, )+import Foreign.ForeignPtr (castForeignPtr, )+import Foreign.Storable (Storable, )+import Foreign.Marshal.Array (advancePtr, )+import qualified Foreign.Marshal.Array as Array++import System.IO.Unsafe (unsafePerformIO, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- |+This function needs only constant time+in contrast to 'Synthesizer.LLVM.Parameterized.SignalPacked.unpack'.++We cannot provide a 'pack' function+since the array size may not line up.+It would also need copying since the source data may not be aligned properly.+-}+unpackStrict ::+ (Storable a, IsPrimitive a, IsPowerOf2 n) =>+ SV.Vector (Vector n a) -> SV.Vector a+unpackStrict v =+ let getDim :: (TypeNum.Nat n) => SV.Vector (Vector n a) -> n -> Int+ getDim _ = TypeNum.toInt+ d = getDim v undefined+ (fptr,s,l) = SVB.toForeignPtr v+ in SVB.SV (castForeignPtr fptr) (s*d) (l*d)++unpack ::+ (Storable a, IsPrimitive a, IsPowerOf2 n) =>+ SVL.Vector (Vector n a) -> SVL.Vector a+unpack =+ SVL.fromChunks . map unpackStrict . SVL.chunks++{- |+This is similar to 'unpackStrict' but performs rearrangement of data.+This is for instance necessary for stereo signals+where the data layout of packed and unpacked data is different,+thus simple casting of the data is not possible.+-}+makeUnpackGenericStrict ::+ (Vector.Access n va vv,+ Storable a, MakeValueTuple a va, Rep.Memory va as, IsSized as asize,+ Storable v, MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) =>+ IO (SV.Vector v -> SV.Vector a)+makeUnpackGenericStrict =+ let vectorSize ::+ (Vector.Access n al vl, Storable v, MakeValueTuple v vl) =>+ SV.Vector v -> n+ vectorSize _ = undefined+ in fmap (\f v -> f (TypeNum.toInt (vectorSize v) * SV.length v) v) $+ SigP.run (SigPS.unpack $ SigP.fromStorableVector Cat.id)++makeUnpackGeneric ::+ (Vector.Access n va vv,+ Storable a, MakeValueTuple a va, Rep.Memory va as, IsSized as asize,+ Storable v, MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) =>+ IO (SVL.Vector v -> SVL.Vector a)+makeUnpackGeneric =+ fmap (\f -> SVL.fromChunks . map f . SVL.chunks) $+ makeUnpackGenericStrict+++makeReverser ::+ (Storable a, Vector.ShuffleMatch n value,+ MakeValueTuple a value, Rep.Memory value struct) =>+ value -> IO (Word32 -> Ptr a -> Ptr a -> IO ())+-- (Rep.Memory a struct, Vector.ShuffleMatch n a) =>+-- IO (Word32 -> Ptr struct -> Ptr struct -> IO ())+makeReverser dummy =+ fmap (\f len srcPtr dstPtr ->+ f len (Rep.castStorablePtr srcPtr) (Rep.castStorablePtr dstPtr)) $+ fmap derefMixPtr $+ Exec.compileModule $+ createFunction ExternalLinkage $ \ size ptrA ptrB -> do+ ptrAEnd <- getElementPtr ptrA (size, ())+ arrayLoop size ptrB ptrAEnd $ \ ptrBi ptrAj0 -> do+ ptrAj1 <- getElementPtr ptrAj0 (-1 :: Int32, ())+ flip Rep.store ptrBi+ =<< Vector.reverse+ . flip asTypeOf dummy+ =<< Rep.load ptrAj1+ return ptrAj1+ ret ()++makeReversePackedStrict ::+ (Storable v, Vector.Access n va vv,+ MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) =>+ IO (SV.Vector v -> SV.Vector v)+makeReversePackedStrict = do+ rev <- makeReverser undefined+ return $ \v ->+ unsafePerformIO $+ SVB.withStartPtr v $ \ptrA len ->+ SVB.create len $ \ptrB ->+ rev (fromIntegral len) ptrA ptrB++makeReversePacked ::+ (Storable v, Vector.Access n va vv,+ MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) =>+ IO (SVL.Vector v -> SVL.Vector v)+makeReversePacked =+ fmap (\f -> SVL.fromChunks . reverse . map f . SVL.chunks) $+ makeReversePackedStrict+++{- |+Append two signals where the second signal+gets the last value of the first signal as parameter.+If the first signal is empty+then there is no parameter for the second signal+and thus we simply return an empty signal in that case.+-}+continue ::+ (Storable a) =>+ SVL.Vector a -> (a -> SVL.Vector a) -> SVL.Vector a+continue x y =+ SVL.fromChunks $+ withLast SV.empty+ (SVL.chunks x)+ (SV.switchR [] $ \_ -> SVL.chunks . y)++_continueNeglectLast ::+ (Storable a) =>+ SVL.Vector a -> (a -> SVL.Vector a) -> SVL.Vector a+_continueNeglectLast x y =+ SVL.switchR SVL.empty+ (\body l -> SVL.append body (y l)) x++continuePacked ::+ (IsPowerOf2 n, Storable a, IsPrimitive a) =>+ SVL.Vector (Vector n a) ->+ (a -> SVL.Vector (Vector n a)) ->+ SVL.Vector (Vector n a)+continuePacked x y =+ SVL.fromChunks $+ withLast SV.empty+ (SVL.chunks x)+ (SV.switchR [] (\_ -> SVL.chunks . y) .+ unpackStrict)++{-+This function reduces the last chunk to size one, repacks that+and takes the last value.+It would be certainly more efficient to use+a single @Rep.load@, @extractelement@ and @store@+instead of a loop of count 1.+However, this implementation is the simplest one, so far.+-}+{- |+Use this like++> do unpackGeneric <- makeUnpackGenericStrict+> return (continuePackedGeneric unpackGeneric x y)+-}+continuePackedGeneric ::+{-+ (Storable v, Vector.Access n a v,+ MakeValueTuple v vv, Rep.Memory vv vs, IsSized vs vsize) =>+-}+ (Storable v, Storable a) =>+ (SV.Vector v -> SV.Vector a) ->+ SVL.Vector v -> (a -> SVL.Vector v) -> SVL.Vector v+continuePackedGeneric unpackGeneric x y =+ SVL.fromChunks $+ withLast SV.empty+ (SVL.chunks x)+ (\lastChunk ->+ SV.switchR [] (\_ -> SVL.chunks . y) $ unpackGeneric $+ SV.drop (SV.length lastChunk - 1) $ lastChunk)+++-- candidate for utility-ht+withLast :: a -> [a] -> (a -> [a]) -> [a]+withLast deflt x y =+ foldr+ (\a cont _ -> a : cont a)+ y x deflt++{-+This version is too strict, since it looks one element ahead.+-}+_withLast :: [a] -> (a -> [a]) -> [a]+_withLast x y =+ ListHT.switchR []+ (\body end -> body ++ end : y end)+ x++++foreign import ccall safe "dynamic" derefFillPtr ::+ Exec.Importer (Word32 -> Ptr a -> IO ())++{- |+'fillBuffer' is not only more general than filling with zeros,+it also simplifies type inference.+-}+fillBuffer ::+ (MakeValueTuple a value, Rep.Memory value struct) =>+ value -> IO (Word32 -> Ptr a -> IO ())+fillBuffer x =+ fmap (\f len ptr -> f len (Rep.castStorablePtr ptr)) $+ fmap derefFillPtr $+ Exec.compileModule $+ createFunction ExternalLinkage $ \ size ptr -> do+ arrayLoop size ptr () $ \ ptri () -> do+ Rep.store x ptri+ return ()+ ret ()+++foreign import ccall safe "dynamic" derefMixPtr ::+ Exec.Importer (Word32 -> Ptr a -> Ptr a -> IO ())++makeMixer ::+ (Storable a, Sample.Additive value,+ MakeValueTuple a value, Rep.Memory value struct) =>+ value -> IO (Word32 -> Ptr a -> Ptr a -> IO ())+makeMixer dummy =+ fmap (\f len srcPtr dstPtr ->+ f len (Rep.castStorablePtr srcPtr) (Rep.castStorablePtr dstPtr)) $+ fmap derefMixPtr $+ Exec.compileModule $+ createFunction ExternalLinkage $ \ size srcPtr dstPtr -> do+ arrayLoop size srcPtr dstPtr $ \ srcPtri dstPtri -> do+ y <- Rep.load srcPtri+ Rep.modify (Sample.add (y `asTypeOf` dummy)) dstPtri+ advanceArrayElementPtr dstPtri+ ret ()+++addToBuffer ::+ (Storable a) =>+ (Word32 -> Ptr a -> Ptr a -> IO ()) ->+ Int -> Ptr a -> Int -> SVL.Vector a -> IO (Int, SVL.Vector a)+addToBuffer addChunkToBuffer len v start xs =+ let (now,future) = SVL.splitAt (len - start) xs+ go i [] = return i+ go i (c:cs) =+ SVB.withStartPtr c (\ptr l ->+ addChunkToBuffer (fromIntegral l) ptr (advancePtr v i)) >>+ go (i + SV.length c) cs+ in fmap (flip (,) future) . go start . SVL.chunks $ now+++{-+Same algorithm as in Synthesizer.Storable.Cut.arrangeEquidist+-}+makeArranger ::+ (Storable a, Sample.Additive value,+ MakeValueTuple a value, Rep.Memory value struct) =>+ IO (SVL.ChunkSize ->+ EventList.T NonNeg.Int (SVL.Vector a) ->+ SVL.Vector a)+makeArranger = do+ mixer <- makeMixer undefined+ fill <- fillBuffer Sample.zero+ return $ \ (SVL.ChunkSize sz) ->+ let sznn = NonNeg.fromNumberMsg "arrange" sz+ go acc evs =+ let (now,future) = EventListTM.splitAtTime sznn evs+ xs =+ AbsEventList.toPairList $+ EventList.toAbsoluteEventList 0 $+ EventListTM.switchTimeR const now+ (chunk,newAcc) =+ unsafePerformIO $+ SVB.createAndTrim' sz $ \ptr -> do+ fill (fromIntegral sz) ptr+ newAcc0 <- flip mapM acc $ addToBuffer mixer sz ptr 0+ newAcc1 <- flip mapM xs $ \(i,s) ->+ addToBuffer mixer sz ptr (NonNeg.toNumber i) s+ let (ends, suffixes) = unzip $ newAcc0++newAcc1+ {- if there are more events to come,+ we must pad with zeros -}+ len =+ if EventList.null future+ then foldl max 0 ends+ else sz+ return (0, len,+ filter (not . SVL.null) suffixes)+ in if SV.null chunk+ then []+ else chunk : go newAcc future+ in SVL.fromChunks . go []++{- |+This is unsafe since it relies on the prior initialization of the LLVM JIT.+Better use 'makeArranger'.+-}+arrange ::+ (Storable a, Sample.Additive value,+ MakeValueTuple a value, Rep.Memory value struct) =>+ SVL.ChunkSize+ -> EventList.T NonNeg.Int (SVL.Vector a)+ {-^ A list of pairs: (relative start time, signal part),+ The start time is relative to the start time+ of the previous event. -}+ -> SVL.Vector a+ {-^ The mixed signal. -}+arrange =+ unsafePerformIO makeArranger
+ src/Synthesizer/LLVM/Test.hs view
@@ -0,0 +1,1288 @@+{-# LANGUAGE Rank2Types #-}+module Main where++import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass+import qualified Synthesizer.LLVM.Filter.Allpass as Allpass+import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth+import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev+import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1+import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2+import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P+import qualified Synthesizer.LLVM.Filter.Moog as Moog+import qualified Synthesizer.LLVM.Filter.Universal as UniFilter+import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP+import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS+import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Simple.Signal as Sig+import qualified Synthesizer.LLVM.Storable.Signal as SigLSt+import qualified Synthesizer.LLVM.Sample as Sample+import qualified Synthesizer.LLVM.Wave as Wave+import qualified Synthesizer.LLVM.Parameter as Param++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Representation as Rep+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.Core as LLVM+import Data.TypeLevel.Num (D4, D8, D16, )+import qualified Data.TypeLevel.Num as TypeNum++import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), )+import Synthesizer.LLVM.Parameterized.Signal (($#), )++import qualified Synthesizer.Plain.Filter.Recursive as FiltR+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core++import Control.Arrow (Arrow, arr, (&&&), (^<<), )+import Control.Category ((<<<), (.), id, )++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Data.EventList.Relative.BodyTime as EventListBT+import qualified Data.EventList.Relative.MixedTime as EventListMT+import qualified Data.EventList.Relative.TimeMixed as EventListTM+import qualified Numeric.NonNegative.Wrapper as NonNeg++import qualified Sound.Sox.Option.Format as SoxOption+import qualified Sound.Sox.Play as SoxPlay+-- import qualified Synthesizer.Storable.ALSA.Play as Play++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import Data.Word (Word32, )+-- import qualified Data.Function.HT as F+import Data.List (genericLength, )+import System.Random (randomRs, mkStdGen, )++import qualified System.IO as IO+import System.Exit (ExitCode, )++import Prelude hiding (fst, snd, id, (.), )+import qualified Prelude as P+++asMono :: vector Float -> vector Float+asMono = id++asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float)+asStereo = id++asMonoPacked :: vector (LLVM.Vector D4 Float) -> vector (LLVM.Vector D4 Float)+asMonoPacked = id++asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float)+asMonoPacked16 = id++asWord32 :: vector Word32 -> vector Word32+asWord32 = id++asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32)+asWord32Packed = id+++{- |+> playStereo (Sig.amplifyStereo 0.3 $ stereoOsciSaw 0.01)++Unfortunately: If you call :reload,+then the next attempt to play something will be answered by:++ghci: JITEmitter.cpp:110: <unnamed>::JITResolver::JITResolver(llvm::JIT&): Assertion `TheJITResolver == 0 && "Multiple JIT resolvers?"' failed.+-}+playStereo :: Sig.T (Stereo.T (Value Float)) -> IO ExitCode+playStereo =+ playStereoVector .+ Sig.renderChunky (SVL.chunkSize 100000)++playStereoVector :: SVL.Vector (Stereo.T Float) -> IO ExitCode+playStereoVector =+ SoxPlay.simple SVL.hPut SoxOption.none 44100++playMono :: Sig.T (Value Float) -> IO ExitCode+playMono =+ playMonoVector .+ Sig.renderChunky (SVL.chunkSize 100000)++playMonoVector :: SVL.Vector Float -> IO ExitCode+playMonoVector =+ SoxPlay.simple SVL.hPut SoxOption.none 44100+++playFileMono :: FilePath -> IO ()+playFileMono fileName = do+ IO.withFile fileName IO.ReadMode $ \h ->+ playStereo .+ Sig.fromStorableVectorLazy .+ asStereo . snd+ =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h+ return ()+++saw :: IO ()+saw =+ SV.writeFile "speedtest.f32" $+ asMono $+ Sig.render 10000000 $+ Sig.osciSaw 0 0.01++exponential :: IO ()+exponential =+ SV.writeFile "speedtest.f32" $+ asMono $+ Sig.render 10000000 $+ Sig.exponential2 50000 1++triangle :: IO ()+triangle =+ SV.writeFile "speedtest.f32" $+ asMono $+ Sig.render 10000000 $+ Sig.osci Wave.triangle 0.25 0.01++trianglePack :: IO ()+trianglePack =+ SV.writeFile "speedtest.f32" $+ asMonoPacked $+ (\xs -> SigP.render xs (div 10000000 4) ()) $+ SigP.mapSimple Wave.triangle $+ SigPS.packSmall $+ SigP.osciCore 0.25 0.01++trianglePacked :: IO ()+trianglePacked =+ SV.writeFile "speedtest.f32" $+ asMonoPacked $+ (\xs -> SigP.render xs (div 10000000 4) ()) $+ (CausalPS.osciSimple Wave.triangle+ $< SigPS.constant 0.25+ $* SigPS.constant 0.01)++triangleReplicate :: IO ()+triangleReplicate =+ SV.writeFile "speedtest.f32" $+ asMonoPacked $+ (\xs -> SigP.render xs (div 10000000 4) ()) $+ (CausalPS.shapeModOsci+ (\k p -> do+ x <- Wave.triangle =<< Wave.replicate k p+ y <- Wave.approxSine4 =<< Wave.halfEnvelope p+ A.mul x y)+ $< SigPS.rampInf 1000000+ $< SigPS.constant 0+ $* SigPS.constant 0.01)++rationalSine :: IO ()+rationalSine =+ SV.writeFile "speedtest.f32" $+ asMonoPacked $+ (\xs -> SigP.render xs (div 10000000 4) ()) $+ (CausalPS.shapeModOsci Wave.rationalApproxSine1+ $< SigP.mapSimple (A.add (valueOf 0.001)) (SigPS.rampInf 10000000)+ $< SigPS.constant 0+ $* SigPS.constant 0.01)+++pingSig :: Float -> Sig.T (Value Float)+pingSig freq =+ Sig.envelope+ (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)++ping :: IO ()+ping =+ SV.writeFile "speedtest.f32" $+ asMono $+ Sig.render 10000000 $+ pingSig 0.01++pingSigPacked :: SigP.T Float (Value (Vector D4 Float))+pingSigPacked =+ let freq = id+ in SigP.envelope+ (SigPS.exponential2 50000 1)+ (SigPS.osciSimple Wave.saw 0 freq)++pingPacked :: IO ()+pingPacked =+ SV.writeFile "speedtest.f32" $+ asMonoPacked $+ (\xs -> SigP.render xs (div 10000000 4) 0.01) $+ pingSigPacked++pingUnpack :: IO ()+pingUnpack =+ SV.writeFile "speedtest.f32" $+ asMono $+ (\xs -> SigP.render xs 10000000 0.01) $+ SigPS.unpack $+ pingSigPacked++pingSmooth :: IO ()+pingSmooth =+ SV.writeFile "speedtest-scalar.f32" $+ asMono $+ (\xs -> SigP.render xs 10000000 ()) $+ (Filt1.lowpassCausalP+ $< (fmap Filt1Core.Parameter $+ SigP.mapSimple (A.sub (valueOf 1))+ (SigP.exponential2 50000 $# (1::Float)))+ $* SigP.osciSimple Wave.triangle 0 0.01)++pingSmoothPacked :: IO ()+pingSmoothPacked =+ SV.writeFile "speedtest-vector.f32" $+ asMonoPacked $+ (\xs -> SigP.render xs (div 10000000 4) ()) $+ (Filt1.lowpassCausalPackedP+ $< (fmap Filt1Core.Parameter $+ SigP.mapSimple (A.sub (valueOf 1))+ (SigP.exponential2 (50000/4) $# (1::Float)))+ $* SigPS.osciSimple Wave.triangle 0 0.01)++stereoOsciSaw :: Float -> Sig.T (Stereo.T (Value Float))+stereoOsciSaw freq =+ Sig.zipWith Sample.zipStereo+ (Sig.osciSaw 0.0 (freq*1.001) `Sig.mix`+ Sig.osciSaw 0.2 (freq*1.003) `Sig.mix`+ Sig.osciSaw 0.1 (freq*0.995))+ (Sig.osciSaw 0.1 (freq*1.005) `Sig.mix`+ Sig.osciSaw 0.7 (freq*0.997) `Sig.mix`+ Sig.osciSaw 0.5 (freq*0.999))++stereoOsciSawPacked :: Float -> Sig.T (Stereo.T (Value Float))+stereoOsciSawPacked freq =+ let mix4 =+ Sample.mixVector .+ flip asTypeOf (undefined :: Value (Vector D4 Float))+ in Sig.zipWith Sample.zipStereo+ (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]))+ (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]))++stereoOsciSawPacked2 :: Float -> Sig.T (Stereo.T (Value Float))+stereoOsciSawPacked2 freq =+ Sig.map (Sample.mixVectorToStereo .+ flip asTypeOf (undefined :: Value (Vector D8 Float))) $+ Sig.osciPlain (Wave.trapezoidSkew (SoV.replicateOf 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])++stereo :: IO ()+stereo =+ SV.writeFile "speedtest.f32" $+ asStereo $+ Sig.render 10000000 $+ Sig.amplifyStereo 0.25 $+ stereoOsciSawPacked2 0.01++lazy :: IO ()+lazy =+ SVL.writeFile "speedtest.f32" $+ SVL.take 10000000 $+ asMono $+ Sig.renderChunky (SVL.chunkSize 100000)+ {- SVL.defaultChunkSize - too slow -} $+ Sig.envelope+ (Sig.exponential2 50000 1)+ (Sig.osci Wave.sine 0.5 0.01 :: Sig.T (Value Float))++lazyStereo :: IO ()+lazyStereo =+ SVL.writeFile "speedtest.f32" $+ SVL.take 10000000 $+ asStereo $+ Sig.renderChunky (SVL.chunkSize 100000) $+ Sig.amplifyStereo 0.25 $+ stereoOsciSawPacked 0.01++packTake :: IO ()+packTake =+ SVL.writeFile "speedtest.f32" $+ asMonoPacked $+ flip (SigP.renderChunky (SVL.chunkSize 1000)) () $+ SigPS.packRotate $+ (CausalP.take 5 $*+ SigP.osciSimple Wave.saw 0 0.01)++chord :: Float -> Sig.T (Stereo.T (Value Float))+chord base =+ {-+ This exceeds available vector registers+ and thus needs more stack accesses.+ Thus it needs twice as much time as the simple mixing.+ However doing all 32 oscillators in parallel+ and mix them in one go might be still faster.++ foldl1 (Sig.zipWith Sample.mixStereoV) $+ -}+ foldl1 Sig.mixStereo $+ map (\f -> stereoOsciSawPacked2 (base*f)) $+ 0.25 : 1.00 : 1.25 : 1.50 : []++lazyChord :: IO ()+lazyChord =+ SVL.writeFile "speedtest.f32" $+ SVL.take 10000000 $+ asStereo $+ Sig.renderChunky (SVL.chunkSize 100000) $+ Sig.amplifyStereo 0.1 $+ chord 0.005++filterSweepComplex :: IO ()+filterSweepComplex =+ SVL.writeFile "speedtest.f32" $+ SVL.take 10000000 $+ asStereo $+ Sig.renderChunky (SVL.chunkSize 100000) $+ Sig.amplifyStereo 0.3 $+ Causal.apply BandPass.causal $+ Sig.zip+ (Sig.map (BandPass.parameter (valueOf 100)) $+ Sig.map (\x -> 0.01 * exp (2 * return x)) $+ Sig.osci Wave.sine 0 (0.1/44100)) $+ chord 0.005++lfoSine ::+ (Rep.Memory a ap, LLVM.IsSized ap asize) =>+ (forall r. Value Float -> LLVM.CodeGenFunction r a) ->+ Param.T p Float ->+ SigP.T p a+lfoSine f reduct =+ SigP.mapSimple f $+ SigP.mapSimple (\x -> 0.01 * exp (2 * return x)) $+ SigP.osciSimple Wave.sine 0 (reduct * 0.1/44100)++filterSweep :: IO ()+filterSweep =+ SVL.writeFile "speedtest.f32" $+ SVL.take 10000000 $+ asMono $+ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $+ (CausalP.amplify 0.2 .+ CtrlP.processCtrlRate 128+ (lfoSine (Filt2.bandpassParameter (valueOf 100)))+ $* SigP.osciSimple Wave.saw 0 0.01)++filterSweepPacked :: IO ()+filterSweepPacked =+ SVL.writeFile "speedtest.f32" $+ SVL.take (div 10000000 4) $+ asMonoPacked $+ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $+ (CausalP.amplify 0.2 .+ CtrlPS.processCtrlRate 128+ (lfoSine (Filt2.bandpassParameter (valueOf 100)))+ $* SigPS.osciSimple Wave.saw 0 0.01)++exponentialFilter2Packed :: IO ()+exponentialFilter2Packed =+ SVL.writeFile "speedtest.f32" $+ SVL.take (div 10000000 16) $+ asMonoPacked16 $+ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $+ (Filt2.causalPackedP+ $< (SigP.constant $#+ Filt2Core.Parameter (1::Float) 0 0 0 0.99)+ $* (+-- (CausalP.delay1 $# LLVM.vector [0.1,0.01,0.001,0.0001::Float])+-- (CausalP.delay1 $# LLVM.vector [1::Float])+ (CausalP.delay1 $# LLVM.vector ((1::Float):repeat 0))+ $* (SigP.constant $# LLVM.vector [0::Float])))++filterSweepPacked2 :: IO ()+filterSweepPacked2 =+ SVL.writeFile "speedtest.f32" $+ SVL.take 10000000 $+ asMono $+ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $+ (CausalP.amplify 0.2 .+ CtrlP.processCtrlRate 128+ (lfoSine (Filt2P.bandpassParameter (valueOf 100)))+ $* SigP.osciSimple Wave.saw 0 0.01)++butterworthNoisePacked :: IO ()+butterworthNoisePacked =+ SVL.writeFile "speedtest.f32" $+ SVL.take (div 10000000 4) $+ asMonoPacked $+ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $+ (CausalPS.amplify 0.2 .+ CtrlPS.processCtrlRate 128+ (lfoSine (Butterworth.parameter TypeNum.d3 FiltR.Lowpass (valueOf 0.5)))+ $* SigPS.noise 0 0.3)++chebyshevNoisePacked :: IO ()+chebyshevNoisePacked =+ SVL.writeFile "speedtest.f32" $+ SVL.take (div 10000000 4) $+ asMonoPacked $+ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $+ (CausalPS.amplify 0.2 .+ CtrlPS.processCtrlRate 128+ (lfoSine (Chebyshev.parameterA TypeNum.d5 FiltR.Lowpass (valueOf 0.5)))+ $* SigPS.noise 0 0.3)++{-+Provoke non-aligned vector accesses by calling alloca for a record of 5 floats+in LLVM-2.6.+However, the vector accesses are those of noise.+Using scalar Noise there is no problem.+-}+noiseAllocaBug :: IO ()+noiseAllocaBug =+ SVL.writeFile "speedtest.f32" $+ SVL.take (div 10000000 4) $+ asMonoPacked $+ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $+ (CausalPS.amplify 0.2 . Filt2.causalPackedP+ $< (SigP.mapSimple (const $ Rep.load =<< LLVM.alloca) $+ (SigP.constant $# (0::Float)))+ $* SigPS.noise 0 0.3)++noiseAllocaScalar :: IO ()+noiseAllocaScalar =+ SVL.writeFile "speedtest.f32" $+ SVL.take 10000000 $+ asMono $+ flip (SigP.renderChunky (SVL.chunkSize 10000)) () $+ (CausalP.amplify 0.2 . Filt2.causalP+ $< (SigP.mapSimple (const $+ (Rep.load =<< LLVM.alloca ::+ LLVM.CodeGenFunction r (Filt2.Parameter (Value Float)))) $+ (SigP.constant $# (0::Float)))+ $* SigP.noise 0 0.3)+++upsample :: IO ()+upsample =+ SVL.writeFile "speedtest.f32" $+ SVL.take 10000000 $+ asMono $+ Sig.renderChunky (SVL.chunkSize 100000) $+ (let reduct = 128 :: Float+ in Sig.interpolateConstant reduct $+ Sig.osci Wave.sine 0 (reduct*0.1/44100))+++filterSweepControlRateCausal ::+ Causal.T+ (Stereo.T (Value Float))+ (Stereo.T (Value Float))+filterSweepControlRateCausal =+ Causal.amplifyStereo 0.3 <<<+ BandPass.causal <<<+ Causal.feedFst+ (let reduct = 128+ in Sig.interpolateConstant reduct $+ Sig.map (BandPass.parameter (valueOf 100)) $+ Sig.map (\x -> 0.01 * exp (2 * return x)) $+ Sig.osci Wave.sine 0 (reduct*0.1/44100))++filterSweepControlRateProc ::+ Sig.T (Stereo.T (Value Float)) ->+ Sig.T (Stereo.T (Value Float))+filterSweepControlRateProc =+ Causal.apply filterSweepControlRateCausal++{- |+Trigonometric functions are very slow in LLVM+because they are translated to calls to C's math library.+Thus it is advantageous to compute filter parameters+at a lower rate and interpolate constantly.+-}+filterSweepControlRate :: IO ()+filterSweepControlRate =+ SVL.writeFile "speedtest.f32" $+ asStereo $+ SVL.take 10000000 $+ Sig.renderChunky (SVL.chunkSize 100000) $+ filterSweepControlRateProc $+ chord 0.005+++filterSweepMusic :: IO ()+filterSweepMusic =+ do music <- SV.readFile "lichter.f32"+ SVL.writeFile "speedtest.f32" $+ asStereo $+ Sig.renderChunky (SVL.chunkSize 100000) $+ Sig.amplifyStereo 20 $+ filterSweepControlRateProc $+ Sig.fromStorableVector $+ (music :: SV.Vector (Stereo.T Float))+++playFilterSweepMusicLazy :: IO ()+playFilterSweepMusicLazy = do+ IO.withFile "lichter.f32" IO.ReadMode $ \h ->+ playStereo .+-- Sig.amplifyStereo 1.125 .+ Sig.amplifyStereo 20 .+ filterSweepControlRateProc .+ Sig.fromStorableVectorLazy .+ asStereo . snd+ =<< SVL.hGetContentsAsync (SVL.chunkSize 4321) h+ return ()++playFilterSweepMusicCausal :: IO ()+playFilterSweepMusicCausal = do+ do music <- SV.readFile "lichter.f32"+ SoxPlay.simple SV.hPut SoxOption.none 44100 $+ asStereo $+ Causal.applyStorable+ (Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) $+ (music :: SV.Vector (Stereo.T Float))+ return ()++playFilterSweepMusicCausalLazy :: IO ()+playFilterSweepMusicCausalLazy = do+ IO.withFile "lichter.f32" IO.ReadMode $ \h ->+ playStereoVector .+ Causal.applyStorableChunky+ (Causal.amplifyStereo 20 <<< filterSweepControlRateCausal) .+ asStereo . snd+ =<< SVL.hGetContentsAsync (SVL.chunkSize 43210) h+ return ()++arrangeLazy :: IO ()+arrangeLazy = do+ IO.hSetBuffering IO.stdout IO.NoBuffering+ print $+ SigLSt.arrange (SVL.chunkSize 2) $+ EventList.fromPairList $+ (0, SVL.pack (SVL.chunkSize 2) [1,2::Double]) :+ (0, SVL.pack (SVL.chunkSize 2) [3,4,5,6]) :+ (2, SVL.pack (SVL.chunkSize 2) [7,8,9,10]) :+ -- repeat (2, SVL.empty)+-- (2, SVL.empty) :+-- (2, SVL.empty) :+-- (2::NonNeg.Int, error "undefined sound") :+ error "end of list"+ -- []+++{- |+This is inefficient because pingSig is compiled by LLVM+for every occurence of the sound!++randomTones :: IO ()+randomTones = do+ playMonoVector $+ SigLSt.arrange (SVL.chunkSize 12345) $+ EventList.fromPairList $ zip+ (cycle $ map (flip div 16 . (44100*)) [1,2,3])+ (cycle $ map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 54321) .+ pingSig . (0.01*))+ [1,1.25,1.5,2])+ return ()+-}++{- |+So far we have not managed to compile signals+that depend on parameters.+Thus in order to avoid much recompilation,+we compile and render a few sounds in advance.+-}+pingTones :: [SVL.Vector Float]+pingTones =+ map (SVL.take 44100 . Sig.renderChunky (SVL.chunkSize 4321) .+ pingSig . (0.01*))+ [1,1.25,1.5,2]++pingTonesIO :: IO [SVL.Vector Float]+pingTonesIO =+ fmap+ (\pingVec ->+ map+ (SVL.take 44100 .+ pingVec (SVL.chunkSize 4321) .+ (0.01*))+ [1,1.25,1.5,2])+ (SigP.runChunky pingSigP)++{-+Arrange itself does not seem to have a space leak with temporary data.+However it may leak sound data.+This is not very likely because this would result in a large memory leak.++Generate random tones in order to see whether generated sounds leak.+How does 'arrange' compare with 'concat'?+-}++cycleTones :: IO ()+cycleTones = do+-- playMono $+ pings <- pingTonesIO+ SVL.writeFile "test.f32" $+-- Play.auto (0.01::Double) 44100 $+ asMono $+{-+after 13min runtime memory consumption increased from 2.5 to 3.9+and we get lot of buffer underruns with this implementation of amplification+(renderChunky . amplify . fromStorableVector)+-}+ Sig.renderChunky (SVL.chunkSize 432109) $+ Sig.amplify 0.1 $+ Sig.fromStorableVectorLazy $+{-+after 20min memory consumption increased from 2.5 to 3.4+and we get lot of buffer underruns with applyStorableChunky+-}+{-+applyStorableChunky applied to concatenated zero vectors+starts with memory consumption 1.0 and after an hour, it's still 1.1+without buffer underruns.+-}+{-+ CausalP.applyStorableChunky (CausalP.amplify $# (0.1::Float)) () $+ asMono $+-}+{-+with chunksize 12345678+after 50min runtime the memory consumption increased from 12.0 to 26.2++with chunksize 123+after 25min runtime the memory consumption is constant 7.4+however at start time there 5 buffer underruns, but no more+probably due to initial LLVM compilation++with chunksize 1234567 and SVL.replicate instead of pingTones+we get memory consumption from 1.3 to 3.2 in 15min,+while producing lots of buffer underruns.+After 45min in total, it is still 3.2 of memory consumption.+Is this a memory leak, or isn't it?++with chunksize 12345678 and SVL.replicate+we get from 5.6 to 10.2 in 3min+to 14.9 after total 13min.+-}+{-+ SigLSt.arrange (SVL.chunkSize 12345678) $+ EventList.fromPairList $ zip+ (repeat (div 44100 8))+-- (cycle $ map (flip div 4 . (44100*)) [1,2,3])+-}+{-+With plain concatenation of those zero vectors+we stay constantly at 0.4 memory consumption and no buffer underruns over 30min.+-}+ SVL.concat+ (cycle pings)+-- (repeat $ SVL.replicate (SVL.chunkSize 44100) 44100 0)+ return ()+++tonesChunkSize :: SVL.ChunkSize+numTones :: Int++{-+For one-time-compiled fill functions,+larger chunks have no relevant effect on the processing speed.+-}+(tonesChunkSize, numTones) =+ (SVL.chunkSize 441, 200)+-- (SVL.chunkSize 44100, 200)++fst :: Arrow arrow => arrow (a,b) a+fst = arr P.fst++snd :: Arrow arrow => arrow (a,b) b+snd = arr P.snd+++{-# NOINLINE makePing #-}+makePing :: IO ((Float,Float) -> SVL.Vector Float)+makePing =+ let freq = snd+ halfLife = fst+ in fmap ($tonesChunkSize) $+ SigP.runChunky+ (SigP.envelope+ (SigP.exponential2 halfLife 1)+ (SigP.osciSaw 0.5 freq))++tonesDown :: IO ()+tonesDown = do+ let dist = div 44100 10+ pingp <- makePing+ playMonoVector $+ CausalP.applyStorableChunky (CausalP.amplify id) 0.03 $+ SigLSt.arrange tonesChunkSize $+ EventList.fromPairList $ zip+ (repeat (NonNeg.fromNumber dist))+ (map (SVL.take (numTones * dist) . curry pingp 50000) $+ iterate (0.999*) 0.01)+ return ()+++vibes :: SigP.T (Float,Float) (Value Float)+vibes =+ let freq = snd+ modDepth = fst+ halfLife = 5000+ -- sine = Wave.sine+ sine = Wave.approxSine4+ in CausalP.envelope+ $< SigP.exponential2 halfLife 1+ $* (((CausalP.osciSimple sine+ $< (CausalP.envelope+ $< SigP.exponential2 halfLife modDepth+ $* (CausalP.osciSimple sine+ $* SigP.constant (return (0::Float) &&& (2*freq)))))+ <<<+ CausalP.mapLinear (0.01*freq) freq+ <<<+ CausalP.osciSimple sine)+ $* SigP.constant (return (0::Float, 0.0001::Float)))++makeVibes :: IO ((Float,Float) -> SVL.Vector Float)+makeVibes =+ fmap ($tonesChunkSize) $+ SigP.runChunky vibes++vibesCycleVector :: ((Float,Float) -> SVL.Vector Float) -> SVL.Vector Float+vibesCycleVector pingp =+ SigLSt.arrange tonesChunkSize $+ EventList.fromPairList $ zip+ (repeat 5000)+ (map (SVL.take 50000 . pingp) $+ zip+ (map (\k -> 0.5 * (1 - cos k)) $ iterate (0.05+) 0)+ (cycle $ map (0.01*) [1, 1.25, 1.5, 2]))++vibesCycle :: IO ()+vibesCycle = do+ pingp <- makeVibes+ playMonoVector $+ CausalP.applyStorableChunky (CausalP.amplify id) 0.2 $+ vibesCycleVector pingp+ return ()++vibesEcho :: IO ()+vibesEcho = do+ pingp <- makeVibes+ playMonoVector $+ CausalP.applyStorableChunky+ (CausalP.amplify id <<<+ CausalP.comb 0.5 7000)+ 0.2 $+ vibesCycleVector pingp+ return ()++vibesReverb :: IO ()+vibesReverb = do+ pingp <- makeVibes+ playMonoVector $+ CausalP.applyStorableChunky+ (CausalP.amplify id <<<+ CausalP.reverb (mkStdGen 142) 16 (0.9,0.97) (400,1000))+ 0.3 $+ vibesCycleVector pingp+ return ()++vibesReverbStereo :: IO ()+vibesReverbStereo = do+ pingp <- makeVibes+ playStereoVector $+ CausalP.applyStorableChunky+ (CausalP.amplifyStereo id <<<+ CausalP.stereoFromChannels+ (CausalP.reverb (mkStdGen 142) 16 (0.9,0.97) (400,1000))+ (CausalP.reverb (mkStdGen 857) 16 (0.9,0.97) (400,1000)) <<<+ CausalP.mapSimple Sample.stereoFromMono)+ 0.3 $+ vibesCycleVector pingp+ return ()++++stair :: IO ()+stair =+ SVL.writeFile "speedtest.f32" $+ SVL.take 10000000 $+ asMono $+ flip (SigP.renderChunky tonesChunkSize) () $+ SigP.piecewiseConstant $+ return $+ EventListBT.fromPairList $+ zip+ (iterate (/2) (1::Float))+ (iterate (2*) (1::NonNeg.Int))+++filterBass :: IO ()+filterBass = do+ playStereoVector $+ asStereo $+ flip (SigP.renderChunky tonesChunkSize) () $+ CausalP.apply+ (BandPass.causalP+ <<<+ CausalP.feedSnd+ (SigP.zipWithSimple Sample.zipStereo+ (SigP.osciSimple Wave.saw 0 0.001499)+ (SigP.osciSimple Wave.saw 0 0.001501))+ <<<+ CausalP.mapSimple (BandPass.parameter (valueOf (100::Float)))) $+ SigP.piecewiseConstant $+ return $ EventListBT.fromPairList $+ zip+ (map (((0.03::Float)*) . (2**) . (/12) . fromInteger) $+ randomRs (0,12) (mkStdGen 998))+ (repeat (10000::NonNeg.Int))++ return ()+++{- |+This function is not very efficient,+since it compiles an LLVM mixing routine+for every pair of mixer inputs.+-}+mixVectorRecompile ::+ SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float+mixVectorRecompile xs ys =+ Sig.renderChunky tonesChunkSize $+ Sig.mix+ (Sig.fromStorableVectorLazy xs)+ (Sig.fromStorableVectorLazy ys)++mixVectorParamIO ::+ IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float)+mixVectorParamIO =+ fmap curry $+ fmap ($tonesChunkSize) $+ SigP.runChunky+ (SigP.mix+ (SigP.fromStorableVectorLazy fst)+ (SigP.fromStorableVectorLazy snd))++mixVectorCausalIO ::+ IO (SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float)+mixVectorCausalIO =+ CausalP.runStorableChunky+ (CausalP.mix $<+ SigP.fromStorableVectorLazy id)++mixVectorCausal ::+ SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float+mixVectorCausal =+ CausalP.applyStorableChunky+ (CausalP.mix $<+ SigP.fromStorableVectorLazy id)++mixVectorStereo ::+ SVL.Vector (Stereo.T Float) ->+ SVL.Vector (Stereo.T Float) ->+ SVL.Vector (Stereo.T Float)+mixVectorStereo =+ CausalP.applyStorableChunky+ (CausalP.mixStereo $<+ SigP.fromStorableVectorLazy id)++mixVectorStereoIO ::+ IO (SVL.Vector (Stereo.T Float) ->+ SVL.Vector (Stereo.T Float) ->+ SVL.Vector (Stereo.T Float))+mixVectorStereoIO =+ CausalP.runStorableChunky+ (CausalP.mixStereo $<+ SigP.fromStorableVectorLazy id)++{-+slightly slower than mixVectorParam+-}+mixVectorHaskell ::+ SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float+mixVectorHaskell = SVL.zipWith (+)++toneMix :: IO ()+toneMix = do+ pingp <- makePing+ mix <- mixVectorCausalIO+ playMonoVector $+ Causal.applyStorableChunky (Causal.amplify 0.1) $+ foldl1 mix $+ map (curry pingp 1000000) $+ take numTones $+ iterate (*(2/3)) 0.01+ return ()++fadeEnvelope :: SigP.T (Int, Int) (Value Float)+fadeEnvelope =+ SigP.parabolaFadeIn (fmap fromIntegral fst)+ `SigP.append`+ (CausalP.take snd $* (SigP.constant $# (1::Float)))+ `SigP.append`+ SigP.parabolaFadeOut (fmap fromIntegral fst)++fadeEnvelopeWrite :: IO ()+fadeEnvelopeWrite =+ SVL.writeFile "speedtest.f32" $+ asMono $+ SigP.renderChunky (SVL.chunkSize 1234)+ fadeEnvelope (100000, 200000)+++-- | normalize a list of numbers, such that they have a specific average+-- Cf. haskore-supercollider/src/Haskore/Interface/SuperCollider/Example.hs+normalizeLevel :: Fractional a => a -> [a] -> [a]+normalizeLevel newAvrg xs =+ let avrg = sum xs / genericLength xs+ in map ((newAvrg-avrg)+) xs++stereoOsciSawP :: SigP.T Float (Stereo.T (Value Float))+stereoOsciSawP =+ let freq = id+ n = 5+ volume = 1 / sqrt (fromIntegral n)+ detunes =+ normalizeLevel 1 $ take (2*n) $+ randomRs (0,0.03) $ mkStdGen 912+ phases =+ randomRs (0,1) $ mkStdGen 54+ tones =+ zipWith+ (\phase detune ->+ (SigP.osciSaw $# phase) (fmap (detune*) freq))+ phases detunes+ (tonesLeft,tonesRight) = splitAt n tones+ in SigP.zipWithSimple+ (\l r ->+ Sample.amplifyStereo (valueOf volume)+ =<< Sample.zipStereo l r)+ (foldl1 SigP.mix tonesLeft)+ (foldl1 SigP.mix tonesRight)++stereoOsciSawVector :: Float -> SVL.Vector (Stereo.T Float)+stereoOsciSawVector =+ SigP.renderChunky tonesChunkSize stereoOsciSawP++stereoOsciSawChord :: [Float] -> SVL.Vector (Stereo.T Float)+stereoOsciSawChord =+ foldl1 mixVectorStereo . map stereoOsciSawVector++stereoOsciSawPad :: Int -> [Float] -> SVL.Vector (Stereo.T Float)+stereoOsciSawPad dur pitches =+ let attack = 20000+ in CausalP.applyStorableChunky+ (CausalP.envelopeStereo $< fadeEnvelope)+ (attack, dur-attack)+ (stereoOsciSawChord pitches)++a0, as0, b0, c1, cs1, d1, ds1, e1, f1, fs1, g1, gs1,+ a1, as1, b1, c2, cs2, d2, ds2, e2, f2, fs2, g2, gs2,+ a2, as2, b2, c3, cs3, d3, ds3, e3, f3, fs3, g3, gs3,+ a3, as3, b3, c4, cs4, d4, ds4, e4, f4, fs4, g4, gs4 :: Float+a0 : as0 : b0 : c1 : cs1 : d1 : ds1 : e1 : f1 : fs1 : g1 : gs1 :+ a1 : as1 : b1 : c2 : cs2 : d2 : ds2 : e2 : f2 : fs2 : g2 : gs2 :+ a2 : as2 : b2 : c3 : cs3 : d3 : ds3 : e3 : f3 : fs3 : g3 : gs3 :+ a3 : as3 : b3 : c4 : cs4 : d4 : ds4 : e4 : f4 : fs4 : g4 : gs4 : _ =+ iterate ((2 ** recip 12) *) (55/44100)+++chordSequence :: [(Int, [Float])]+chordSequence =+ (2, [f1, f2, a2, c3]) :+ (1, [g1, g2, b2, d3]) :+ (2, [c2, g2, c3, e3]) :+ (1, [f1, a2, c3, f3]) :+ (2, [g1, g2, b2, d3]) :+ (1, [gs1, gs2, b2, e3]) :+ (2, [a1, e2, a2, c3]) :+ (1, [g1, g2, b2, d3]) :+ (3, [c2, g2, c3, e3]) :++ (2, [f1, f2, a2, c3]) :+ (1, [g1, g2, b2, d3]) :+ (2, [c2, g2, c3, e3]) :+ (1, [f1, a2, c3, f3]) :+ (2, [g1, g2, b2, d3]) :+ (1, [gs1, gs2, b2, e3]) :+ (2, [a1, e2, a2, c3]) :+ (1, [g1, g2, b2, e3]) :+ (3, [c2, e2, g2, c3]) :+ []+++withDur :: (Int -> a -> v) -> Int -> a -> (v, NonNeg.Int)+withDur f d ps =+ let dur = d*30000+ in (f dur ps, NonNeg.fromNumber dur)+++padMusic :: IO ()+padMusic = do+ playStereoVector $+ CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.1 $+ SigLSt.arrange tonesChunkSize $+ EventListTM.switchTimeR const $+ EventListMT.consTime 0 $+ EventListBT.fromPairList $+ map (\(d,ps) -> withDur stereoOsciSawPad d ps)+ chordSequence+ return ()+++lowpassSweepControlRateCausal ::+ CausalP.T p+ (Stereo.T (Value Float))+ (Stereo.T (Value Float))+lowpassSweepControlRateCausal =+-- CausalP.stereoFromVector $+ CausalP.stereoFromMono $+ UniFilter.lowpass ^<<+ CtrlP.processCtrlRate 128+ (lfoSine (UniFilter.parameter (valueOf (10::Float))))+++moogSweepControlRateCausal ::+ CausalP.T p+ (Stereo.T (Value Float))+ (Stereo.T (Value Float))+moogSweepControlRateCausal =+-- CausalP.stereoFromVector $+ CausalP.stereoFromMono $+ CtrlP.processCtrlRate 128+ (lfoSine (Moog.parameter TypeNum.d8 (valueOf (10::Float))))+++filterMusic :: IO ()+filterMusic = do+ playStereoVector $+ CausalP.applyStorableChunky+ (CausalP.amplifyStereo id <<<+ moogSweepControlRateCausal) 0.05 $+ SigLSt.arrange tonesChunkSize $+ EventListTM.switchTimeR const $+ EventListMT.consTime 0 $+ EventListBT.fromPairList $+ map (\(d,ps) -> withDur stereoOsciSawPad d ps)+ chordSequence+ return ()++++stereoOsciSawVectorIO :: IO (Float -> SVL.Vector (Stereo.T Float))+stereoOsciSawVectorIO =+ fmap ($tonesChunkSize) $+ SigP.runChunky $+ stereoOsciSawP++applyFadeEnvelopeIO ::+ IO (Int -> SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float))+applyFadeEnvelopeIO =+ fmap+ (\envelope dur sig ->+ let attack = 20000+ in envelope (attack, dur-attack) sig)+ (CausalP.runStorableChunky+ (CausalP.envelopeStereo $< fadeEnvelope))++stereoOsciSawChordIO :: IO ([Float] -> SVL.Vector (Stereo.T Float))+stereoOsciSawChordIO = do+ sawv <- stereoOsciSawVectorIO+ mix <- mixVectorStereoIO+ return (foldl1 mix . map sawv)++stereoOsciSawPadIO :: IO (Int -> [Float] -> SVL.Vector (Stereo.T Float))+stereoOsciSawPadIO = do+ chrd <- stereoOsciSawChordIO+ envelope <- applyFadeEnvelopeIO+ return $+ \ dur pitches -> envelope dur (chrd pitches)++padMusicIO :: IO ()+padMusicIO = do+ pad <- stereoOsciSawPadIO+ playStereoVector $+ CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.08 $+ SigLSt.arrange tonesChunkSize $+ EventListTM.switchTimeR const $+ EventListMT.consTime 0 $+ EventListBT.fromPairList $+ map (uncurry (withDur pad)) $+ chordSequence+ return ()++{-+Apply the envelope separately to each tone of the chord+and mix all tones by 'arrange'.+-}+padMusicSeparate :: IO ()+padMusicSeparate = do+ osci <- stereoOsciSawVectorIO+ env <- applyFadeEnvelopeIO+ playStereoVector $+ CausalP.applyStorableChunky (CausalP.amplifyStereo id) 0.08 $+ SigLSt.arrange tonesChunkSize $+ EventList.flatten $+ EventListTM.switchTimeR const $+ EventListMT.consTime 0 $+ EventListBT.fromPairList $+ map (uncurry (withDur (\d ps -> map (\p -> env d (osci p)) ps))) $+ chordSequence+ return ()+++delay :: IO ()+delay =+ SVL.writeFile "speedtest.f32" $+ asMono $+ flip (SigP.renderChunky tonesChunkSize) (0, 10000) $+ CausalP.apply+ ((CausalP.delay $# (0::Float)) fst+ <<< CausalP.take snd) $+ SigP.osciSaw 0 0.01++++allpassControl ::+ (TypeNum.Nat n) =>+ n ->+ SigP.T Float (Allpass.CascadeParameter n (Value Float))+allpassControl order =+ let reduct = id+ in SigP.interpolateConstant reduct $+ lfoSine (Allpass.flangerParameter order) reduct++allpassPhaserCausal, allpassPhaserPipeline ::+ SigP.T Float (Value Float) ->+ SigP.T Float (Value Float)+allpassPhaserCausal =+ let order = TypeNum.d16+ in CausalP.apply $+ CausalP.amplify 0.5 <<<+ Allpass.phaserP <<<+ CausalP.feedFst (allpassControl order)++allpassPhaserPipeline =+ let order = TypeNum.d16+ in -- (F.nest (TypeNum.toInt order) SigP.tail .) $+ (SigP.drop (return $ TypeNum.toInt order) .) $+ CausalP.apply $+ CausalP.amplify 0.5 <<<+ Allpass.phaserPipelineP <<<+ CausalP.feedFst (allpassControl order)++allpassPhaser :: IO ()+allpassPhaser =+ SVL.writeFile "speedtest.f32" $+ asMono $+ SVL.take 10000000 $+ flip (SigP.renderChunky (SVL.chunkSize 100000)) 128 $+ allpassPhaserPipeline $+ (SigP.osciSaw 0 0.01)++noise :: IO ()+noise =+ SVL.writeFile "speedtest.f32" $+ asMono $+ SVL.take 10000000 $+ flip (SigP.renderChunky (SVL.chunkSize 100000)) () $+ (SigP.noise 0 0.3)++noisePacked :: IO ()+noisePacked =+ SVL.writeFile "speedtest.f32" $+ asMonoPacked $+ SVL.take (div 10000000 4) $+ flip (SigP.renderChunky (SVL.chunkSize 100000)) () $+ (SigPS.noise 0 0.3)+-- (SigPS.pack (SigP.noise 0 0.3))+-- (SigPS.packSmall (SigP.noise 0 0.3))++frequencyModulationStorable :: IO ()+frequencyModulationStorable = do+ smp <- SigP.runChunky (SigP.osciSaw 0 0.01)+ SVL.writeFile "speedtest.f32" $+ asMono $+ flip (SigP.renderChunky (SVL.chunkSize 100000)) () $+ (CausalP.frequencyModulationLinear+ (SigP.fromStorableVectorLazy $#+ (SVL.take 1000000 $ asMono $+ smp (SVL.chunkSize 1000) ()))+ $*# (0.3::Float))++frequencyModulation :: IO ()+frequencyModulation =+ SVL.writeFile "speedtest.f32" $+ asMono $+ SVL.take 10000000 $+ flip (SigP.renderChunky (SVL.chunkSize 100000)) () $+ (CausalP.frequencyModulationLinear+ (SigP.osciSaw 0 0.01)+ $* SigP.exponential2 500000 1)++frequencyModulationStereo :: IO ()+frequencyModulationStereo = do+ smp <- SigP.runChunky (SigP.osciSaw 0 0.01)+ SVL.writeFile "speedtest.f32" $+ asStereo $+ flip (SigP.renderChunky (SVL.chunkSize 100000)) () $+ (CausalP.stereoFromMono+ (CausalP.frequencyModulationLinear+ (SigP.fromStorableVectorLazy $#+ (SVL.take 1000000 $ asMono $+ smp (SVL.chunkSize 1000) ())))+ $*# Stereo.cons (0.2999::Float) 0.3001)+++quantize :: IO ()+quantize =+{-+ SV.writeFile "speedtest.f32" $+ asMono $+ (\xs -> SigP.render xs 10000000 ()) $+-}+ SVL.writeFile "speedtest.f32" $+ asMono $+ SVL.take 10000000 $+ flip (SigP.renderChunky (SVL.chunkSize 100000)) () $+ ((CausalP.quantizeLift $# (5.5::Float)) id $*+ SigP.osciSaw 0 0.01)++quantizedFilterControl :: IO ()+quantizedFilterControl =+ SVL.writeFile "speedtest.f32" $+ asMono $+ SVL.take 10000000 $+ flip (SigP.renderChunky (SVL.chunkSize 100000)) () $+ CausalP.apply (CausalP.amplify 0.3 <<< UniFilter.lowpass ^<< CtrlP.process) $+ SigP.zip+ ((CausalP.quantizeLift $# (128::Float))+ (CausalP.mapSimple (UniFilter.parameter (valueOf 100)) <<<+-- (CausalP.mapSimple (Moog.parameter TypeNum.d8 (valueOf 100)) <<<+ CausalP.mapSimple (\x -> 0.01 * exp (2 * return x)))+ $* (SigP.osciSimple Wave.approxSine2 $# (0::Float)) (0.1/44100)) $+ (SigP.osciSaw $# (0::Float)) 0.01+++main :: IO ()+main = do+ LLVM.initializeNativeTarget+ frequencyModulationStereo
+ src/Synthesizer/LLVM/Wave.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.LLVM.Wave where++import qualified Synthesizer.LLVM.Simple.Value as Value+import qualified LLVM.Extra.ScalarOrVector as SoV++import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Monad as M++import qualified LLVM.Core as LLVM+import LLVM.Core+ (Value, CodeGenFunction,+ IsFloating, IsArithmetic, IsConst, )++import Control.Monad.HT ((<=<), )++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (replicate, )++++saw ::+ (Ring.C a, IsConst a, SoV.Replicate a v, IsArithmetic v) =>+ Value v -> CodeGenFunction r (Value v)+saw =+ A.sub (SoV.replicateOf 1) <=<+ A.mul (SoV.replicateOf 2)++square ::+ (Ring.C a, IsConst a,+ SoV.Replicate a v, SoV.Fraction v, SoV.Real v) =>+ Value v -> CodeGenFunction r (Value v)+square =+ A.sub (SoV.replicateOf 1) <=<+ A.mul (SoV.replicateOf 2) <=<+ SoV.truncate <=<+ A.mul (SoV.replicateOf 2)++triangle ::+ (Field.C a, IsConst a,+ SoV.Replicate a v, SoV.Fraction v, SoV.Real v) =>+ Value v -> CodeGenFunction r (Value v)+triangle =+ flip A.sub (SoV.replicateOf 1) <=<+ SoV.abs <=<+ flip A.sub (SoV.replicateOf 2) <=<+ A.mul (SoV.replicateOf 4) <=<+ SoV.incPhase (SoV.replicateOf 0.75)++approxSine2 ::+ (Ring.C a, IsConst a, SoV.Replicate a v, SoV.Real v) =>+ Value v -> CodeGenFunction r (Value v)+approxSine2 t = do+ x <- saw t+ A.mul (SoV.replicateOf 4) =<<+ A.mul x =<<+ A.sub (SoV.replicateOf 1) =<<+ SoV.abs x++approxSine3 ::+ (Field.C a, IsConst a,+ SoV.Replicate a v, SoV.Fraction v, SoV.Real v) =>+ Value v -> CodeGenFunction r (Value v)+approxSine3 t = do+ x <- triangle t+ A.mul (SoV.replicateOf 0.5) =<<+ A.mul x =<<+ A.sub (SoV.replicateOf 3) =<<+ A.mul x x++approxSine4 ::+ (Field.C a, IsConst a, SoV.Replicate a v, SoV.Real v) =>+ Value v -> CodeGenFunction r (Value v)+approxSine4 t = do+ x <- saw t+ ax <- SoV.abs x+ sax <- A.sub (SoV.replicateOf 1) ax+ A.mul (SoV.replicateOf (16/5)) =<<+ A.mul x =<<+ A.mul sax =<<+ A.add (SoV.replicateOf 1) =<<+ A.mul sax ax++{- |+For the distortion factor @recip pi@ you get the closest approximation+to an undistorted cosine or sine.+We have chosen this scaling in order to stay with field operations.+-}+rationalApproxCosine1, rationalApproxSine1 ::+ (Field.C a, IsConst a, SoV.Replicate a v, SoV.Real v, IsFloating v) =>+ Value v -> Value v -> CodeGenFunction r (Value v)+rationalApproxCosine1 k t = do+ num2 <-+ A.square =<<+ A.mul k =<<+ A.add (SoV.replicateOf (-1)) =<<+ A.mul (SoV.replicateOf 2) t+ den2 <-+ A.square =<<+ A.mul t =<<+ A.sub (SoV.replicateOf 1) t+ M.liftR2 A.fdiv+ (A.sub num2 den2)+ (A.add num2 den2)++rationalApproxSine1 k t = do+ num <-+ A.mul k =<<+ A.add (SoV.replicateOf (-1)) =<<+ A.mul (SoV.replicateOf 2) t+ den <-+ A.mul t =<<+ A.sub (SoV.replicateOf 1) t+ M.liftR2 A.fdiv+ (A.mul (SoV.replicateOf (-2)) =<< A.mul num den)+ (M.liftR2 A.add (A.square num) (A.square den))+++trapezoidSkew ::+ (Field.C a, IsConst a,+ SoV.Replicate a v, SoV.Fraction v, SoV.Real v) =>+ Value v -> Value v -> CodeGenFunction r (Value v)+trapezoidSkew p =+ SoV.max (SoV.replicateOf (-1)) <=<+ SoV.min (SoV.replicateOf 1) <=<+ flip A.fdiv p <=<+ A.sub (SoV.replicateOf 1) <=<+ A.mul (SoV.replicateOf 2)++sine ::+ (Trans.C a, IsFloating a, IsConst a) =>+-- Value a -> TValue r a+ Value a -> CodeGenFunction r (Value a)+sine t =+ A.sin =<< A.mul t =<< Value.decons Value.twoPi++++{- |+This can be used for preprocessing the phase+in order to generate locally faster oscillating waves.+For example++> triangle <=< replicate (valueOf 2.5)++shrinks a triangle wave such that 2.5 periods fit into one.+-}+replicate ::+ (Field.C a, IsConst a,+ SoV.Replicate a v, SoV.Fraction v, SoV.Real v) =>+ Value v -> Value v -> CodeGenFunction r (Value v)+replicate k =+ SoV.fraction <=<+ A.mul k <=<+ flip A.sub (SoV.replicateOf 0.5) <=<+ SoV.incPhase (SoV.replicateOf 0.5)++{- |+Preprocess the phase such that the first half of a wave+is expanded to one period and shifted by 90 degree.+E.g.++> sine <=< halfEnvelope++generates a sequence of sine bows that starts and ends with the maximum.+Such a signal can be used to envelope an oscillation+generated using 'replicate'.+-}+halfEnvelope ::+ (Field.C a, IsConst a,+ SoV.Replicate a v, SoV.Fraction v, SoV.Real v) =>+ Value v -> CodeGenFunction r (Value v)+halfEnvelope =+ A.mul (SoV.replicateOf 0.5) <=<+ SoV.incPhase (SoV.replicateOf 0.5)++partial ::+ (LLVM.IsPrimitive i, LLVM.IsPrimitive a,+ LLVM.IsInteger i, IsFloating a,+ SoV.Replicate a v, SoV.Fraction v) =>+ (Value v -> CodeGenFunction r (Value v)) ->+ Value i ->+ (Value v -> CodeGenFunction r (Value v))+partial w n t =+ w =<<+ SoV.signedFraction =<<+ A.mul t =<<+ SoV.replicate =<<+ LLVM.sitofp n
+ src/Test/Main.hs view
@@ -0,0 +1,22 @@+module Main where++import qualified Test.Synthesizer.LLVM.Filter as Filter+import qualified Test.Synthesizer.LLVM.Packed as Packed++import qualified LLVM.Core as LLVM++import Data.Tuple.HT (mapFst, )+++prefix :: String -> [(String, IO ())] -> [(String, IO ())]+prefix msg =+ map (mapFst (\str -> msg ++ "." ++ str))++main :: IO ()+main = do+ LLVM.initializeNativeTarget+ mapM_ (\(name,test) -> putStr (name ++ ": ") >> test) $+ concat $+ prefix "Filter" Filter.tests :+ prefix "Packed" Packed.tests :+ []
+ src/Test/Synthesizer/LLVM/Filter.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+module Test.Synthesizer.LLVM.Filter (tests) where++import qualified Synthesizer.LLVM.Filter.Allpass as Allpass+import qualified Synthesizer.LLVM.Filter.FirstOrder as FirstOrder+import qualified Synthesizer.LLVM.Filter.SecondOrder as SecondOrder+import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as SecondOrderP+import qualified Synthesizer.LLVM.Filter.Universal as UniFilter+import qualified Synthesizer.LLVM.Filter.Moog as Moog+import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilter+import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as ComplexFilterP++import qualified Synthesizer.Plain.Filter.Recursive.Allpass as AllpassCore+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrderCore+import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilterCore+import qualified Synthesizer.Plain.Filter.Recursive.Moog as MoogCore+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex as ComplexFilterCore++import qualified Synthesizer.LLVM.Parameter as Param+import qualified LLVM.Extra.Representation as Rep+import qualified Synthesizer.LLVM.Wave as Wave+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 Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), )+import Synthesizer.LLVM.Parameterized.Signal (($#), )++import Synthesizer.Plain.Filter.Recursive (Pole(Pole))+-- import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Interpolation.Module as Ip+import qualified Synthesizer.Causal.Interpolation as InterpC+import qualified Synthesizer.Causal.Filter.NonRecursive as FiltC+import qualified Synthesizer.Causal.Displacement as DispC+import qualified Synthesizer.Causal.Process as CausalS+import qualified Synthesizer.Basic.Phase as Phase+import qualified Synthesizer.Basic.Wave as WaveCore+import qualified Synthesizer.State.Displacement as DispS+import qualified Synthesizer.State.Oscillator as OsciS+import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.Basic.Phase as Phase++import qualified Data.StorableVector.Lazy as SVL+import Data.StorableVector.Lazy (ChunkSize, )++import Test.Synthesizer.LLVM.Utility+ (checkSimilarity, checkSimilarityState, rangeFromInt, )++import qualified Control.Category as Cat+import Control.Category ((<<<), )+import Control.Arrow ((&&&), (^<<), (<<^), )++import LLVM.Core (Value, Vector, )+import qualified LLVM.Core as LLVM+import qualified Data.TypeLevel.Num as TypeNum+import Data.TypeLevel.Num (D4, )++import qualified Number.Complex as Complex+import qualified Synthesizer.LLVM.Frame.Stereo as Stereo++import Test.QuickCheck (quickCheck, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++signalLength :: Int+signalLength = 10000+++limitFloat :: SVL.Vector Float -> SVL.Vector Float+limitFloat = SVL.take signalLength++{-+limitStereoFloat :: SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float)+limitStereoFloat = SVL.take signalLength+-}+++lfoSine ::+ (Rep.Memory a ap, LLVM.IsSized ap asize) =>+ (forall r. Value Float -> LLVM.CodeGenFunction r a) ->+ Param.T p Float ->+ SigP.T p a+lfoSine f reduct =+ SigP.interpolateConstant reduct $+ SigP.mapSimple f $+ CausalP.apply (CausalP.mapExponential 2 0.01) $+ SigP.osciSimple Wave.sine 0 (fmap (* (0.1/44100)) reduct)++allpassControl ::+ (TypeNum.Nat n) =>+ n ->+ Param.T p Float ->+ SigP.T p (Allpass.CascadeParameter n (Value Float))+allpassControl order =+ lfoSine (Allpass.flangerParameter order)++allpassPhaserCausal, allpassPhaserPipeline ::+ Param.T p Float ->+ SigP.T p (Value Float) ->+ SigP.T p (Value Float)+allpassPhaserCausal reduct =+ CausalP.apply+ (Allpass.phaserP+ $< allpassControl TypeNum.d16 reduct)++allpassPhaserPipeline reduct xs =+ let order = TypeNum.d16+ in (SigP.drop $# TypeNum.toInt order) $+ (Allpass.phaserPipelineP+ $< allpassControl order reduct+ $* xs)++allpassPipeline :: IO (ChunkSize -> ((Int,Int), Int) -> Bool)+allpassPipeline =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst+ phase = rangeFromInt (0, 0.99) <<^ snd . fst+ reduct = rangeFromInt (10, 100) <<^ snd+ tone = SigP.osciSimple Wave.triangle phase freq+ in checkSimilarity 1e-2 limitFloat+ (allpassPhaserCausal reduct tone)+ (allpassPhaserPipeline reduct tone)++++{- |+Shrink control signal in time+since we can only handle one control parameter per vector chunk.+-}+applyPacked ::+ (Rep.Memory c cp, LLVM.IsSized cp cs) =>+ CausalP.T p+ (c, Value (Vector D4 Float))+ (Value (Vector D4 Float)) ->+ SigP.T p c ->+ SigP.T p (Value (Vector D4 Float)) ->+ SigP.T p (Value (Vector D4 Float))+applyPacked proc cs xs =+ proc+ $< ((SigP.interpolateConstant $#+ (recip $ fromIntegral $ TypeNum.toInt TypeNum.d4 :: Float)) cs)+ $* xs+++allpassPhaserPacked ::+ Param.T p Float ->+ SigP.T p (Value (Vector D4 Float)) ->+ SigP.T p (Value (Vector D4 Float))+allpassPhaserPacked reduct =+ applyPacked Allpass.phaserPackedP+ (allpassControl TypeNum.d16 reduct)++allpassPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool)+allpassPacked =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst+ phase = rangeFromInt (0, 0.99) <<^ snd . fst+ reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd+ tone = SigP.osciSimple Wave.triangle phase freq+ toneP = SigPS.osciSimple Wave.triangle phase freq+ in checkSimilarity 1e-2 limitFloat+ (allpassPhaserCausal reduct tone)+ (SigPS.unpack $ allpassPhaserPacked reduct toneP)+++interpolateConstant :: Float -> SigS.T a -> SigS.T a+interpolateConstant reduct xs =+ CausalS.apply (InterpC.relative Ip.constant 0 xs) $+ SigS.repeat $ recip reduct+++{-# INLINE lfoSineCore #-}+lfoSineCore ::+ (Float -> a) ->+ Float ->+ SigS.T a+lfoSineCore f reduct =+ interpolateConstant reduct $+ SigS.map f $+ DispS.mapExponential 2 0.01 $+ OsciS.static WaveCore.sine zero (reduct * 0.1/44100)++{-# INLINE allpassPhaserCore #-}+allpassPhaserCore ::+ Float ->+ SigS.T Float ->+ SigS.T Float+allpassPhaserCore reduct =+ let order = 16+ in CausalS.apply $+ FiltC.amplify 0.5 <<<+ DispC.mix <<<+ ((CausalS.applyFst (AllpassCore.cascadeCausal order) $+ lfoSineCore (AllpassCore.flangerParameter order) reduct)+ &&&+ Cat.id)++allpassCore :: IO (ChunkSize -> ((Int,Int), Int) -> Bool)+allpassCore =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst+ phase = rangeFromInt (0, 0.99) <<^ snd . fst+ reduct = rangeFromInt (10, 100) <<^ snd+ tone = SigP.osciSimple Wave.triangle phase freq+ toneS p =+ OsciS.static WaveCore.triangle+ (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)+ in checkSimilarityState 1e-2 limitFloat+ (allpassPhaserCausal reduct tone)+ (\p -> allpassPhaserCore (Param.get reduct p) (toneS p))++++diracImpulse :: SigP.T p (Value Float)+diracImpulse =+ (CausalP.delay1 $# (one::Float)) $*+ (SigP.constant $# (zero::Float))++firstOrderConstant ::+ Param.T p Float ->+ SigP.T p (Value Float) ->+ SigP.T p (Value Float)+firstOrderConstant cutOff xs =+ FirstOrder.lowpassCausalP+ $< SigP.constant (FirstOrderCore.parameter ^<< cutOff)+ $* xs++firstOrderExponential :: IO (ChunkSize -> (Int,Int) -> Bool)+firstOrderExponential =+ let cutOff = rangeFromInt (0.001, 0.01) <<^ fst+ gain = exp(-2*pi*cutOff)+ in checkSimilarity 1e-2 limitFloat+ (SigP.amplify (recip (1 - gain)) $+ firstOrderConstant cutOff diracImpulse)+ (SigP.exponentialCore gain $# (one :: Float))++firstOrderCausal ::+ Param.T p Float ->+ SigP.T p (Value Float) ->+ SigP.T p (Value Float)+firstOrderCausal reduct xs =+ FirstOrder.lowpassCausalP+ $< lfoSine FirstOrder.parameter reduct+ $* xs++{-# INLINE firstOrderCore #-}+firstOrderCore ::+ Float ->+ SigS.T Float ->+ SigS.T Float+firstOrderCore reduct =+ CausalS.apply $+ CausalS.applyFst FirstOrderCore.lowpassCausal $+ lfoSineCore FirstOrderCore.parameter reduct++firstOrder :: IO (ChunkSize -> ((Int,Int), Int) -> Bool)+firstOrder =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst+ phase = rangeFromInt (0, 0.99) <<^ snd . fst+ reduct = rangeFromInt (10, 100) <<^ snd+ tone = SigP.osciSimple Wave.triangle phase freq+ toneS p =+ OsciS.static WaveCore.triangle+ (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)+ in checkSimilarityState 1e-2 limitFloat+ (firstOrderCausal reduct tone)+ (\p -> firstOrderCore (Param.get reduct p) (toneS p))++firstOrderCausalPacked ::+ Param.T p Float ->+ SigP.T p (Value (Vector D4 Float)) ->+ SigP.T p (Value (Vector D4 Float))+firstOrderCausalPacked reduct =+ applyPacked+ (FirstOrder.lowpassCausalPackedP)+ (lfoSine FirstOrder.parameter reduct)++firstOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool)+firstOrderPacked =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst+ phase = rangeFromInt (0, 0.99) <<^ snd . fst+ reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd+ tone = SigP.osciSimple Wave.triangle phase freq+ toneP = SigPS.osciSimple Wave.triangle phase freq+ in checkSimilarity 1e-2 limitFloat+ (firstOrderCausal reduct tone)+ (SigPS.unpack $ firstOrderCausalPacked reduct toneP)+++secondOrderCausal ::+ Param.T p Float ->+ SigP.T p (Value Float) ->+ SigP.T p (Value Float)+secondOrderCausal reduct xs =+ SecondOrder.causalP+ $< lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct+ $* xs++secondOrderCausalPacked ::+ Param.T p Float ->+ SigP.T p (Value (Vector D4 Float)) ->+ SigP.T p (Value (Vector D4 Float))+secondOrderCausalPacked reduct =+ applyPacked SecondOrder.causalPackedP+ (lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct)++secondOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool)+secondOrderPacked =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst+ phase = rangeFromInt (0, 0.99) <<^ snd . fst+ reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd+ tone = SigP.osciSimple Wave.triangle phase freq+ toneP = SigPS.osciSimple Wave.triangle phase freq+ in checkSimilarity 1e-2 limitFloat+ (secondOrderCausal reduct tone)+ (SigPS.unpack $ secondOrderCausalPacked reduct toneP)++secondOrderCausalPacked2 ::+ Param.T p Float ->+ SigP.T p (Value Float) ->+ SigP.T p (Value Float)+secondOrderCausalPacked2 reduct xs =+ SecondOrderP.causalP+ $< lfoSine (SecondOrderP.bandpassParameter (LLVM.valueOf (10::Float))) reduct+ $* xs++secondOrderPacked2 :: IO (ChunkSize -> ((Int,Int), Int) -> Bool)+secondOrderPacked2 =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst+ phase = rangeFromInt (0, 0.99) <<^ snd . fst+ reduct = rangeFromInt (10, 100) <<^ snd+ tone = SigP.osciSimple Wave.triangle phase freq+ in checkSimilarity 1e-2 limitFloat+ (secondOrderCausal reduct tone)+ (secondOrderCausalPacked2 reduct tone)+++{-+limitUniFilter ::+ SVL.Vector (UniFilterCore.Result Float) ->+ SVL.Vector (UniFilterCore.Result Float)+limitUniFilter = SVL.take signalLength+-}++universalCausal ::+ Param.T p Float ->+ SigP.T p (Value Float) ->+ SigP.T p (UniFilter.Result (Value Float))+universalCausal reduct xs =+ UniFilter.causalP+ $< lfoSine (UniFilter.parameter (LLVM.valueOf (10::Float))) reduct+ $* xs++{-# INLINE universalCore #-}+universalCore ::+ Float ->+ SigS.T Float ->+ SigS.T (UniFilterCore.Result Float)+universalCore reduct =+ CausalS.apply $+ CausalS.applyFst UniFilterCore.causal $+ lfoSineCore (UniFilterCore.parameter . Pole 10) reduct++universal :: IO (ChunkSize -> ((Int,Int), Int) -> Bool)+universal =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst+ phase = rangeFromInt (0, 0.99) <<^ snd . fst+ reduct = rangeFromInt (10, 100) <<^ snd+ tone = SigP.osciSimple Wave.triangle phase freq+ toneS p =+ OsciS.static WaveCore.triangle+ (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)+ in checkSimilarityState 1e-2 limitFloat+ (fmap UniFilter.lowpass $+ universalCausal reduct tone)+ (\p ->+ SigS.map UniFilterCore.lowpass $+ universalCore (Param.get reduct p) (toneS p))+{-+ checkSimilarityState 1e-2 limitUniFilter+ (universalCausal reduct tone)+ (\p -> universalCore (Param.get reduct p) (toneS p))+-}+++moogCausal ::+ (TypeNum.Nat n) =>+ n ->+ Param.T p Float ->+ SigP.T p (Value Float) ->+ SigP.T p (Value Float)+moogCausal order reduct xs =+ Moog.causalP+ $< lfoSine (Moog.parameter order (LLVM.valueOf (10::Float))) reduct+ $* xs++{-# INLINE moogCore #-}+moogCore ::+ Int ->+ Float ->+ SigS.T Float ->+ SigS.T Float+moogCore order reduct =+ CausalS.apply $+ CausalS.applyFst (MoogCore.lowpassCausal order) $+ lfoSineCore (MoogCore.parameter order . Pole 10) reduct++moog :: IO (ChunkSize -> ((Int,Int), Int) -> Bool)+moog =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst+ phase = rangeFromInt (0, 0.99) <<^ snd . fst+ reduct = rangeFromInt (10, 100) <<^ snd+ order = TypeNum.d6+ tone = SigP.osciSimple Wave.triangle phase freq+ toneS p =+ OsciS.static WaveCore.triangle+ (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)+ in checkSimilarityState 1e-2 limitFloat+ (moogCausal order reduct tone)+ (\p -> moogCore (TypeNum.toInt order) (Param.get reduct p) (toneS p))+++complexCausal ::+ Param.T p Float ->+ SigP.T p (Value Float) ->+ SigP.T p (Stereo.T (Value Float))+complexCausal reduct =+ CausalP.apply $+ (ComplexFilter.causalP+ $< lfoSine (ComplexFilter.parameter (LLVM.valueOf (10::Float))) reduct)+ <<^ (\x -> Stereo.cons x (LLVM.value LLVM.zero))++complexCausalPacked ::+ Param.T p Float ->+ SigP.T p (Value Float) ->+ SigP.T p (Stereo.T (Value Float))+complexCausalPacked reduct =+ CausalP.apply $+ (ComplexFilterP.causalP+ $< lfoSine (ComplexFilterP.parameter (LLVM.valueOf (10::Float))) reduct)+ <<^ (\x -> Stereo.cons x (LLVM.value LLVM.zero))++complexPacked :: IO (ChunkSize -> ((Int,Int), Int) -> Bool)+complexPacked =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst+ phase = rangeFromInt (0, 0.99) <<^ snd . fst+ reduct = rangeFromInt (10, 100) <<^ snd+ tone = SigP.osciSimple Wave.triangle phase freq+ in checkSimilarity 1e-2 limitFloat+ (fmap Stereo.left $+ complexCausal reduct tone)+ (fmap Stereo.left $+ complexCausalPacked reduct tone)++{-# INLINE complexCore #-}+complexCore ::+ Float ->+ SigS.T Float ->+ SigS.T (Stereo.T Float)+complexCore reduct =+ CausalS.apply $+ (\x -> Stereo.cons (Complex.real x) (Complex.imag x)) ^<<+ CausalS.applyFst ComplexFilterCore.causal+ (lfoSineCore (ComplexFilterCore.parameter . Pole 10) reduct)++complex :: IO (ChunkSize -> ((Int,Int), Int) -> Bool)+complex =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst+ phase = rangeFromInt (0, 0.99) <<^ snd . fst+ reduct = rangeFromInt (10, 100) <<^ snd+ tone = SigP.osciSimple Wave.triangle phase freq+ toneS p =+ OsciS.static WaveCore.triangle+ (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)+ in checkSimilarityState 1e-2 limitFloat+ (fmap Stereo.left $+ complexCausal reduct tone)+ (\p ->+ SigS.map ((0.1*) . Stereo.left) $+ complexCore (Param.get reduct p) (toneS p))+{-+ in checkSimilarityState 1e-2 limitStereoFloat+ (complexCausal reduct tone)+ (\p -> complexCore (Param.get reduct p) (toneS p))+-}+++tests :: [(String, IO ())]+tests =+ ("secondOrderPacked", quickCheck =<< secondOrderPacked) :+ ("secondOrderPacked2", quickCheck =<< secondOrderPacked2) :+ ("firstOrderExponential", quickCheck =<< firstOrderExponential) :+ ("firstOrder", quickCheck =<< firstOrder) :+ ("firstOrderPacked", quickCheck =<< firstOrderPacked) :+ ("universal", quickCheck =<< universal) :+ ("allpassPacked", quickCheck =<< allpassPacked) :+ ("allpassPipeline", quickCheck =<< allpassPipeline) :+ ("allpassCore", quickCheck =<< allpassCore) :+ ("moog", quickCheck =<< moog) :+ ("complexPacked", quickCheck =<< complexPacked) :+ ("complex", quickCheck =<< complex) :+ []
+ src/Test/Synthesizer/LLVM/Packed.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Test.Synthesizer.LLVM.Packed (tests) where++import Test.Synthesizer.LLVM.Utility+ (checkSimilarity, checkEquality, rangeFromInt, )++import qualified Synthesizer.LLVM.Wave as Wave+import qualified Synthesizer.LLVM.Parameter as Param++import LLVM.Core (Value, Vector, )+import qualified LLVM.Core as LLVM+import Data.TypeLevel.Num (D4, )+import qualified Data.TypeLevel.Num as TypeNum++import qualified Synthesizer.LLVM.Generator.Exponential2 as Exp+import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS+import qualified Synthesizer.LLVM.Parameterized.Signal as SigP+import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP+import Synthesizer.LLVM.Parameterized.Signal (($#), )+import Synthesizer.LLVM.CausalParameterized.Process (($*), )++import qualified Synthesizer.LLVM.Storable.Signal as SigStL+import qualified Data.StorableVector.Lazy as SVL+import Data.StorableVector.Lazy (ChunkSize, )++import Control.Arrow ((^<<), (<<^), (<<<), )++import Data.Word (Word32, )++import Test.QuickCheck (quickCheck, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++signalLength :: Int+signalLength = 10000+++limitFloat :: SVL.Vector Float -> SVL.Vector Float+limitFloat = SVL.take signalLength++{-+limitPackedFloat ::+ SVL.Vector (Vector D4 Float) -> SVL.Vector (Vector D4 Float)+limitPackedFloat = SVL.take (div signalLength 4)+-}++constant :: IO (ChunkSize -> Int -> Bool)+constant =+ let y = rangeFromInt (-1, 1)+ in checkSimilarity 1e-3 limitFloat+ (SigP.constant y)+ (SigPS.unpack (SigPS.constant y ::+ SigP.T Int (Value (Vector D4 Float))))++ramp :: IO (ChunkSize -> Int -> Bool)+ramp =+ let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength)+ in checkSimilarity 1e-3 limitFloat+ (SigP.rampInf dur)+ (SigPS.unpack (SigPS.rampInf dur ::+ SigP.T Int (Value (Vector D4 Float))))++parabolaFadeIn :: IO (ChunkSize -> Int -> Bool)+parabolaFadeIn =+ let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength)+ in checkSimilarity 1e-3 limitFloat+ (SigP.parabolaFadeInInf dur)+ (SigPS.unpack (SigPS.parabolaFadeInInf dur ::+ SigP.T Int (Value (Vector D4 Float))))++parabolaFadeOut :: IO (ChunkSize -> Int -> Bool)+parabolaFadeOut =+ let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength)+ in checkSimilarity 1e-3 limitFloat+ (SigP.parabolaFadeOutInf dur)+ (SigPS.unpack (SigPS.parabolaFadeOutInf dur ::+ SigP.T Int (Value (Vector D4 Float))))++parabolaFadeInMap :: IO (ChunkSize -> Int -> Bool)+parabolaFadeInMap =+ let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength)+ in checkSimilarity 1e-3 limitFloat+ (SigP.parabolaFadeIn dur)+ (SigP.parabolaFadeInMap dur)++parabolaFadeOutMap :: IO (ChunkSize -> Int -> Bool)+parabolaFadeOutMap =+ let dur = fromIntegral ^<< rangeFromInt (signalLength,2*signalLength)+ in checkSimilarity 1e-3 limitFloat+ (SigP.parabolaFadeOut dur)+ (SigP.parabolaFadeOutMap dur)++exponential2 :: IO (ChunkSize -> (Int,Int) -> Bool)+exponential2 =+ let halfLife = rangeFromInt (1000,10000) <<^ fst+ start = rangeFromInt ( -1, 1) <<^ snd+ in checkSimilarity 1e-3 limitFloat+ (SigP.exponential2 halfLife start)+ (SigPS.unpack (SigPS.exponential2 halfLife start ::+ SigP.T (Int,Int) (Value (Vector D4 Float))))++exponential2Static :: IO (ChunkSize -> (Int,Int) -> Bool)+exponential2Static =+ let halfLife = rangeFromInt (1000,10000) <<^ fst+ start = rangeFromInt ( -1, 1) <<^ snd+ in checkSimilarity 1e-3 limitFloat+ (SigP.exponential2 halfLife start)+ (Exp.causalP start <<<+ CausalP.mapSimple Exp.parameter $*+ SigP.constant halfLife)++exponential2PackedStatic :: IO (ChunkSize -> (Int,Int) -> Bool)+exponential2PackedStatic =+ let halfLife = rangeFromInt (1000,10000) <<^ fst+ start = rangeFromInt ( -1, 1) <<^ snd+ in checkSimilarity 1e-3 (limitFloat . SigStL.unpack)+ (SigPS.exponential2 halfLife start ::+ SigP.T (Int,Int) (Value (Vector D4 Float)))+ (Exp.causalPackedP start <<<+ CausalP.mapSimple Exp.parameterPacked $*+ SigP.constant halfLife)++exponential2Controlled :: IO (ChunkSize -> ((Int,Int), (Int,Int)) -> Bool)+exponential2Controlled =+ let halfLife = rangeFromInt (1000,10000) <<^ (fst.fst)+ start = rangeFromInt ( -1, 1) <<^ (snd.fst)+ -- this is the LFO frequency measured at vector-rate+ freq = rangeFromInt (0.0001, 0.001) <<^ (fst.snd)+ phase = rangeFromInt (0, 0.99) <<^ (snd.snd)+ lfo =+ CausalP.mapExponential 2 halfLife $*+ SigP.osciSimple Wave.approxSine2 phase freq+ in checkSimilarity 1e-3 limitFloat+ (Exp.causalP start <<<+ CausalP.mapSimple Exp.parameter $*+ SigP.interpolateConstant+ (fromIntegral (TypeNum.toInt TypeNum.d4) :: Param.T p Float)+ lfo)+ (SigPS.unpack+ (Exp.causalPackedP start <<<+ CausalP.mapSimple Exp.parameterPacked $*+ lfo ::+ SigP.T ((Int,Int),(Int,Int)) (Value (Vector D4 Float))))++osci :: IO (ChunkSize -> (Int,Int) -> Bool)+osci =+ let freq = rangeFromInt (0.001, 0.01) <<^ fst+ phase = rangeFromInt (0, 0.99) <<^ snd+ in checkSimilarity 1e-2 limitFloat+ (SigP.osciSimple Wave.approxSine2 phase freq)+ (SigPS.unpack (SigPS.osciSimple Wave.approxSine2 phase freq ::+ SigP.T (Int,Int) (Value (Vector D4 Float))))++++limitWord32 :: SVL.Vector Word32 -> SVL.Vector Word32+limitWord32 = SVL.take signalLength++limitPackedWord32 ::+ SVL.Vector (Vector D4 Word32) -> SVL.Vector (Vector D4 Word32)+limitPackedWord32 = SVL.take (div signalLength 4)+++noise :: IO (ChunkSize -> () -> Bool)+noise =+ checkEquality limitWord32+ (SigP.noiseCore $# 0)+ (SigP.noiseCoreAlt $# 0)++noiseVector :: IO (ChunkSize -> () -> Bool)+noiseVector =+ checkEquality limitPackedWord32+ (SigPS.noiseCore $# 0)+ (SigPS.noiseCoreAlt $# 0)++noiseScalarVector :: IO (ChunkSize -> () -> Bool)+noiseScalarVector =+ checkEquality limitPackedWord32+ (SigPS.noiseCore $# 0)+ (SigPS.packSmall (SigP.noiseCore $# 0))+++tests :: [(String, IO ())]+tests =+ ("constant", quickCheck =<< constant) :+ ("ramp", quickCheck =<< ramp) :+ ("parabolaFadeIn", quickCheck =<< parabolaFadeIn) :+ ("parabolaFadeOut", quickCheck =<< parabolaFadeOut) :+ ("parabolaFadeInMap", quickCheck =<< parabolaFadeInMap) :+ ("parabolaFadeOutMap", quickCheck =<< parabolaFadeOutMap) :+ ("exponential2", quickCheck =<< exponential2) :+ ("exponential2Static", quickCheck =<< exponential2Static) :+ ("exponential2PackedStatic", quickCheck =<< exponential2PackedStatic) :+ ("exponential2Controlled", quickCheck =<< exponential2Controlled) :+ ("osci", quickCheck =<< osci) :+ ("noise", quickCheck =<< noise) :+ ("noiseVector", quickCheck =<< noiseVector) :+ ("noiseScalarVector", quickCheck =<< noiseScalarVector) :+ []
+ src/Test/Synthesizer/LLVM/Utility.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Test.Synthesizer.LLVM.Utility where++import qualified Synthesizer.LLVM.Parameter as Param+import qualified LLVM.Extra.Representation as Rep+import qualified LLVM.Core as LLVM++import qualified Synthesizer.LLVM.Parameterized.Signal as SigP++import qualified Synthesizer.State.Signal as SigS++import Control.Arrow (arr, )+import Control.Monad (liftM, liftM2, )++import qualified Data.StorableVector.Lazy as SVL+import Data.StorableVector.Lazy (ChunkSize, )+import Foreign.Storable (Storable, )++import qualified Algebra.RealRing as RealRing++import System.Random (Random, randomR, mkStdGen, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++rangeFromInt :: Random a => (a,a) -> Param.T Int a+rangeFromInt rng =+ arr $ fst . randomR rng . mkStdGen+++{-# INLINE checkSimilarityState #-}+checkSimilarityState ::+ (RealRing.C a, Storable a,+ LLVM.MakeValueTuple a av,+ Rep.Memory av ap) =>+ a ->+ (SVL.Vector a -> SVL.Vector a) ->+ SigP.T p av ->+ (p -> SigS.T a) ->+ IO (ChunkSize -> p -> Bool)+checkSimilarityState tol limit gen0 sig1 =+ let render sig =+ fmap+ (\func chunkSize ->+ limit . func chunkSize) $+ SigP.runChunky sig+ in liftM+ (\sig0 chunkSize p ->+ SigS.foldR (&&) True $+ -- dangerous, since shortened signals would be tolerated+ SigS.zipWith (\x y -> abs(x-y) < tol)+ (SigS.fromStorableSignal (sig0 chunkSize p))+ (sig1 p))+ (render gen0)+++{-# INLINE checkSimilarity #-}+checkSimilarity ::+ (RealRing.C b, Storable b,+ Storable a,+ LLVM.MakeValueTuple a av, Rep.Memory av ap) =>+ b ->+ (SVL.Vector a -> SVL.Vector b) ->+ SigP.T p av -> SigP.T p av ->+ IO (ChunkSize -> p -> Bool)+checkSimilarity tol limit gen0 gen1 =+ let render sig =+ fmap+ (\func chunkSize ->+ limit . func chunkSize) $+ SigP.runChunky sig+ in liftM2+ (\sig0 sig1 chunkSize p ->+ SigS.foldR (&&) True $+ -- dangerous, since shortened signals would be tolerated+ SigS.zipWith (\x y -> abs(x-y) < tol)+ (SigS.fromStorableSignal (sig0 chunkSize p))+ (SigS.fromStorableSignal (sig1 chunkSize p)))+ (render gen0)+ (render gen1)+++checkEquality ::+ (Eq a, Storable a,+ LLVM.MakeValueTuple a av,+ Rep.Memory av ap) =>+ (SVL.Vector a -> SVL.Vector a) ->+ SigP.T p av -> SigP.T p av ->+ IO (ChunkSize -> p -> Bool)+checkEquality limit gen0 gen1 =+ let render sig =+ fmap+ (\func chunkSize ->+ limit . func chunkSize) $+ SigP.runChunky sig+ in liftM2+ (\sig0 sig1 chunkSize p ->+ sig0 chunkSize p == sig1 chunkSize p)+ (render gen0)+ (render gen1)
+ synthesizer-llvm.cabal view
@@ -0,0 +1,153 @@+Name: synthesizer-llvm+Version: 0.2+License: GPL+License-File: LICENSE+Author: Henning Thielemann <haskell@henning-thielemann.de>+Maintainer: Henning Thielemann <haskell@henning-thielemann.de>+Homepage: http://www.haskell.org/haskellwiki/Synthesizer+Package-URL: http://code.haskell.org/synthesizer/llvm/+Category: Sound, Music+Synopsis: Efficient signal processing using runtime compilation+Description:+ Efficient signal processing+ using runtime compilation and vector instructions.+ It uses LLVM library, thus it is not bound to a specific CPU.+ If you compile with Cabal flag @buildExamples@+ you get the executable @synthi-llvm-server@,+ that is a realtime software synthesizer+ that receives MIDI events via ALSA+ and in response plays some tones via ALSA.+Stability: Experimental+Tested-With: GHC==6.10.4+Cabal-Version: >=1.2+Build-Type: Simple++Flag buildExamples+ description: Build example executables+ default: False++Flag buildTests+ description: Build test suite+ default: False++Library+ Build-Depends:+ llvm-extra >= 0.1 && <0.2,+ -- llvm must be imported with restrictive version bounds,+ -- because we import implicitly and unqualified+ llvm-ht >=0.7.0 && <0.7.1,+ type-level >=0.2.3 && <0.3,+ functional-arrow >=0.0 && <0.1,+ HList >=0.2 && <0.3,+ synthesizer-core >=0.4 && <0.5,+ -- for ALSA.BendModulation+ synthesizer-alsa >=0.3 && <0.4,+ alsa-seq >=0.5 && <0.6,+ alsa-pcm >=0.5 && <0.6,+ midi >= 0.1.5 && <0.2,+ storable-record >=0.0.2 && <0.1,+ storable-tuple >=0.0.2 && <0.1,+ sox >=0.2 && <0.3,+ sample-frame-np >=0.0.1 && <0.1,+ sample-frame >=0.0.1 && <0.1,+ storablevector >=0.2.6 && <0.3,+ numeric-prelude >=0.2 && <0.3,+ non-negative >=0.1 && <0.2,+ event-list >=0.1 && <0.2,+ -- data-accessor >=0.1 && <0.2,+ random >= 1.0 && < 1.1,+ containers >=0.1 && <0.4,+ transformers >=0.2 && <0.3,+ utility-ht >=0.0.1 && <0.1++ Build-Depends:+ -- base-4 needed for Control.Category+ base >= 4 && <5++ GHC-Options: -Wall+ Hs-source-dirs: src+ Exposed-Modules:+ Synthesizer.LLVM.Simple.Signal+ Synthesizer.LLVM.Simple.Value+ Synthesizer.LLVM.Simple.Vanilla+ Synthesizer.LLVM.Parameterized.Signal+ Synthesizer.LLVM.Parameterized.SignalPacked+ Synthesizer.LLVM.Parameterized.Value+ Synthesizer.LLVM.Parameter+ Synthesizer.LLVM.Storable.Signal+ Synthesizer.LLVM.Causal.Process+ Synthesizer.LLVM.CausalParameterized.Process+ Synthesizer.LLVM.CausalParameterized.ProcessPacked+ Synthesizer.LLVM.CausalParameterized.Controlled+ Synthesizer.LLVM.CausalParameterized.ControlledPacked+ Synthesizer.LLVM.Filter.Allpass+ Synthesizer.LLVM.Filter.Butterworth+ Synthesizer.LLVM.Filter.Chebyshev+ Synthesizer.LLVM.Filter.ComplexFirstOrder+ Synthesizer.LLVM.Filter.ComplexFirstOrderPacked+ Synthesizer.LLVM.Filter.FirstOrder+ Synthesizer.LLVM.Filter.SecondOrder+ Synthesizer.LLVM.Filter.SecondOrderPacked+ Synthesizer.LLVM.Filter.SecondOrderCascade+ Synthesizer.LLVM.Filter.Moog+ Synthesizer.LLVM.Filter.Universal+ Synthesizer.LLVM.Generator.Exponential2+ Synthesizer.LLVM.Sample+ Synthesizer.LLVM.Frame.Stereo+ Synthesizer.LLVM.Wave+ Synthesizer.LLVM.Server.Common+ Synthesizer.LLVM.Server.Packed.Test+ Synthesizer.LLVM.Server.Packed.Run+ Synthesizer.LLVM.Server.Packed.Instrument+ Synthesizer.LLVM.Server.Scalar.Test+ Synthesizer.LLVM.Server.Scalar.Run+ Synthesizer.LLVM.Server.Scalar.Instrument+ -- may be moved to a separate package+ Synthesizer.LLVM.ALSA.MIDI++ Other-Modules:+ Synthesizer.LLVM.Random+ Synthesizer.LLVM.EventIterator+ Synthesizer.LLVM.Storable.ChunkIterator+ Synthesizer.LLVM.Storable.LazySizeIterator+ Synthesizer.LLVM.Parameterized.SignalPrivate+ Synthesizer.LLVM.CausalParameterized.ProcessPrivate+ -- belongs to Synthesizer.LLVM.ALSA.MIDI+ Synthesizer.LLVM.ALSA.BendModulation+ -- may be moved to llvm-extra+ Synthesizer.LLVM.Execution++Executable synthi-llvm-example+ If !flag(buildExamples)+ Buildable: False+ GHC-Options: -Wall+ Hs-Source-Dirs: src+ Main-Is: Synthesizer/LLVM/Test.hs++Executable synthi-llvm-server+ If !flag(buildExamples)+ Buildable: False+ GHC-Options: -Wall -threaded+ Hs-Source-Dirs: src+ Main-Is: Synthesizer/LLVM/Server.hs+ Other-Modules:+ Synthesizer.LLVM.Server.Packed.Instrument+ Synthesizer.LLVM.Server.Packed.Test+ Synthesizer.LLVM.Server.Packed.Run+ Synthesizer.LLVM.Server.Scalar.Instrument+ Synthesizer.LLVM.Server.Scalar.Test+ Synthesizer.LLVM.Server.Scalar.Run+ Synthesizer.LLVM.Server.Common++Executable synthi-llvm-test+ If flag(buildTests)+ Build-Depends: QuickCheck >= 1 && <3+ Else+ Buildable: False+ GHC-Options: -Wall+ Hs-Source-Dirs: src+ Main-Is: Test/Main.hs+ Other-Modules:+ Test.Synthesizer.LLVM.Filter+ Test.Synthesizer.LLVM.Packed+ Test.Synthesizer.LLVM.Utility