synthesizer-llvm 0.8.2.1 → 0.8.3
raw patch · 29 files changed
+536/−567 lines, 29 filesdep ~basedep ~containersdep ~event-list
Dependency ranges changed: base, containers, event-list, llvm-extra, llvm-tf, midi, non-negative, numeric-prelude, optparse-applicative, pathtype, shell-utility, sox, storable-record, storable-tuple, storablevector, synthesizer-core, synthesizer-midi, tfp, transformers, utility-ht
Files
- Changes.md +7/−1
- alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs +1/−1
- example/Synthesizer/LLVM/Test.hs +4/−4
- render/Synthesizer/LLVM/Server/Render.hs +1/−3
- src/Synthesizer/LLVM/Causal/Controlled.hs +2/−10
- src/Synthesizer/LLVM/Causal/Process.hs +5/−12
- src/Synthesizer/LLVM/CausalParameterized/Helix.hs +15/−18
- src/Synthesizer/LLVM/CausalParameterized/Process.hs +4/−5
- src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs +1/−3
- src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs +2/−6
- src/Synthesizer/LLVM/EventIterator.hs +4/−13
- src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs +1/−3
- src/Synthesizer/LLVM/Frame/Binary.hs +1/−1
- src/Synthesizer/LLVM/Frame/SerialVector.hs +0/−2
- src/Synthesizer/LLVM/Frame/Stereo.hs +1/−1
- src/Synthesizer/LLVM/Frame/StereoInterleaved.hs +1/−2
- src/Synthesizer/LLVM/MIDI/BendModulation.hs +2/−5
- src/Synthesizer/LLVM/Parameterized/Signal.hs +185/−80
- src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs +5/−12
- src/Synthesizer/LLVM/Plug/Input.hs +104/−74
- src/Synthesizer/LLVM/Plug/Output.hs +7/−7
- src/Synthesizer/LLVM/Random.hs +18/−155
- src/Synthesizer/LLVM/Simple/SignalPrivate.hs +11/−14
- src/Synthesizer/LLVM/Simple/Value.hs +1/−1
- src/Synthesizer/LLVM/Simple/Vanilla.hs +2/−3
- src/Synthesizer/LLVM/Storable/ChunkIterator.hs +4/−13
- synthesizer-llvm.cabal +101/−103
- testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs +4/−3
- testsuite/Test/Synthesizer/LLVM/Utility.hs +42/−12
Changes.md view
@@ -1,6 +1,12 @@ # Change log for the `synthesizer-llvm` package -## 8.0+## 0.8.3++* `Noise`: caused a crash with LLVM-9+ because it called the X86 intrinsic `pmuludq`.+ Now use generic multiplication.++## 0.8.0 * Compiled code is now freed by the garbage collector if it is no longer needed.
alsa/Synthesizer/LLVM/Server/CausalPacked/Test.hs view
@@ -82,7 +82,7 @@ import Control.Exception (bracket, ) -- import NumericPrelude.Numeric (zero, round, (^?), )-import Prelude hiding (Real, round, break, id, )+import Prelude hiding (Real, id, ) sampleRate :: SampleRate Real
example/Synthesizer/LLVM/Test.hs view
@@ -1596,7 +1596,7 @@ asMono $ SVL.take 10000000 $ flip (SigP.renderChunky (SVL.chunkSize 100000)) () $- (SigP.noise 0 0.3)+ SigP.noise 0 0.3 noisePacked :: IO () noisePacked =@@ -1604,9 +1604,9 @@ 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))+ SigPS.noise 0 0.3+-- SigPS.pack (SigP.noise 0 0.3)+-- SigPS.packSmall (SigP.noise 0 0.3) frequencyModulationStorable :: IO () frequencyModulationStorable = do
render/Synthesizer/LLVM/Server/Render.hs view
@@ -60,9 +60,7 @@ padTime :: Integer padTime = 2 -render ::- Option.T ->- IO (MidiFile.T -> SVL.Vector (Stereo.T Real))+render :: Option.T -> IO (MidiFile.T -> SVL.Vector (Stereo.T Real)) render opt = do proc <- case 0::Int of
src/Synthesizer/LLVM/Causal/Controlled.hs view
@@ -71,9 +71,7 @@ instance (Vector.Arithmetic a, SoV.RationalConstant a,- Memory.C (Value (Filt2P.State a)) {-,- Memory.FirstClass a am, IsSized (Vector TypeNum.D4 a) as,- IsSized am ams, LLVM.IsPrimitive am -}) =>+ Memory.C (Value (Filt2P.State a))) => C (Filt2P.Parameter a) (Value a) (Value a) where type Input (Filt2P.Parameter a) (Value a) = Value a@@ -86,8 +84,7 @@ Memory.FirstClass v, IsSized v, IsSized (Memory.Stored v), TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>- C (Cascade.ParameterValue n a)- (Value v) (Value v) where+ C (Cascade.ParameterValue n a) (Value v) (Value v) where type Input (Cascade.ParameterValue n a) (Value v) = Value v type Output (Cascade.ParameterValue n a) (Value v) = Value v process = Cascade.causal@@ -138,11 +135,6 @@ instance (Vector.Arithmetic a, IsConst a, Memory.C (Value (Filt2P.State a))) =>-{-- (Memory.FirstClass a am, Vector.Arithmetic a, LLVM.IsPrimitive am,- IsSized am ams,- IsSized (Vector TypeNum.D4 a) as) =>--} C (ComplexFiltPack.Parameter a) (Stereo.T (Value a)) (Stereo.T (Value a)) where type Input (ComplexFiltPack.Parameter a) (Stereo.T (Value a)) = Stereo.T (Value a)
src/Synthesizer/LLVM/Causal/Process.hs view
@@ -145,14 +145,10 @@ feedSnd :: Sig.T a -> T b (b,a) feedSnd = CausalClass.feedSnd -feedConstFst ::- (MakeValueTuple a, ValueTuple a ~ al) =>- a -> T b (al,b)+feedConstFst :: (MakeValueTuple a, ValueTuple a ~ al) => a -> T b (al,b) feedConstFst = CausalClass.feedConstFst . Class.valueTupleOf -feedConstSnd ::- (MakeValueTuple a, ValueTuple a ~ al) =>- a -> T b (b,al)+feedConstSnd :: (MakeValueTuple a, ValueTuple a ~ al) => a -> T b (b,al) feedConstSnd = CausalClass.feedConstSnd . Class.valueTupleOf @@ -188,20 +184,17 @@ -} ($*#) :: (C process, CausalClass.SignalOf process ~ signal,- Storable ah, MakeValueTuple ah, ValueTuple ah ~ a,- Memory.C a) =>+ MakeValueTuple ah, ValueTuple ah ~ a) => process a b -> ah -> signal b proc $*# x = CausalClass.applyConst proc $ Class.valueTupleOf x ($<#) ::- (C process,- Storable ah, MakeValueTuple ah, ValueTuple ah ~ a, Memory.C a) =>+ (C process, MakeValueTuple ah, ValueTuple ah ~ a) => process (a,b) c -> ah -> process b c proc $<# x = CausalClass.applyConstFst proc $ Class.valueTupleOf x ($>#) ::- (C process,- Storable bh, MakeValueTuple bh, ValueTuple bh ~ b, Memory.C b) =>+ (C process, MakeValueTuple bh, ValueTuple bh ~ b) => process (a,b) c -> bh -> process a c proc $># x = CausalClass.applyConstSnd proc $ Class.valueTupleOf x
src/Synthesizer/LLVM/CausalParameterized/Helix.hs view
@@ -49,7 +49,6 @@ import LLVM.Core (CodeGenFunction, Value, IsSized, IsFloating, ) import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal (D1, ) import Data.Word (Word32, ) @@ -86,7 +85,7 @@ SoV.RationalConstant a, SoV.Fraction a, Storable a, MakeValueTuple a, ValueTuple a ~ Value a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- LLVM.NumberOfElements a ~ D1) =>+ LLVM.ShapeOf a ~ LLVM.ScalarShape) => (forall r. Ip.T r nodesLeap (Value a) v) -> (forall r. Ip.T r nodesStep (Value a) v) -> Param.T p Int ->@@ -152,7 +151,7 @@ LLVM.CmpRet a, LLVM.CmpResult a ~ Bool, Storable a, MakeValueTuple a, ValueTuple a ~ Value a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- LLVM.NumberOfElements a ~ D1) =>+ LLVM.ShapeOf a ~ LLVM.ScalarShape) => (forall r. Ip.T r nodesLeap (Value a) v) -> (forall r. Ip.T r nodesStep (Value a) v) -> Param.T p Int ->@@ -181,7 +180,7 @@ LLVM.CmpRet a, LLVM.CmpResult a ~ Bool, Storable a, MakeValueTuple a, ValueTuple a ~ Value a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- LLVM.NumberOfElements a ~ D1) =>+ LLVM.ShapeOf a ~ LLVM.ScalarShape) => (forall r. Ip.T r nodesLeap (Value a) v) -> (forall r. Ip.T r nodesStep (Value a) v) -> Param.T p Int ->@@ -215,7 +214,7 @@ LLVM.CmpRet a, LLVM.CmpResult a ~ Bool, Storable a, MakeValueTuple a, ValueTuple a ~ Value a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- LLVM.NumberOfElements a ~ D1) =>+ LLVM.ShapeOf a ~ LLVM.ScalarShape) => (Param.T p (Ip.Margin (nodesLeap (nodesStep v))) -> (Func.T p (Value a, Value a) (Value Word32), Func.T p (Value a, Value a) (Value a)) ->@@ -259,7 +258,7 @@ shapePhases constantFromWord32 ::- (IsFloating a, LLVM.NumberOfElements a ~ TypeNum.D1) =>+ (IsFloating a, LLVM.ShapeOf a ~ LLVM.ScalarShape) => Param.T p Word32 -> Func.T p inp (Value a) constantFromWord32 x = Func.fromSignal@@ -267,7 +266,7 @@ limitMinShape :: (Storable a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- LLVM.NumberOfElements a ~ TypeNum.D1,+ LLVM.ShapeOf a ~ LLVM.ScalarShape, LLVM.IsFloating a, LLVM.CmpRet a, LLVM.CmpResult a ~ Bool) => Param.T p Word32 -> CausalP.T p (Value a) (Value a)@@ -279,7 +278,7 @@ integrateFrac :: (IsFloating a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- LLVM.NumberOfElements a ~ TypeNum.D1) =>+ LLVM.ShapeOf a ~ LLVM.ScalarShape) => CausalP.T p (Value a) (Value Word32, Value a) integrateFrac = CausalP.mapAccumSimple@@ -344,7 +343,7 @@ (IsFloating a, SoV.Fraction a, SoV.RationalConstant a, Storable ah, MakeValueTuple ah, ValueTuple ah ~ Value a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,- LLVM.NumberOfElements a ~ D1) =>+ LLVM.ShapeOf a ~ LLVM.ScalarShape) => Param.T p Word32 -> Param.T p ah -> CausalP.T p@@ -379,8 +378,7 @@ flattenShapePhase :: (IsFloating a, SoV.Fraction a, SoV.RationalConstant a,- LLVM.NumberOfElements a ~ LLVM.NumberOfElements i,- LLVM.IsInteger i) =>+ LLVM.ShapeOf a ~ LLVM.ShapeOf i, LLVM.IsInteger i) => Value i -> Value a -> Value a -> Value a ->@@ -402,8 +400,7 @@ You must make sure, that the argument is non-negative. -} splitFraction ::- (IsFloating a, LLVM.IsInteger i,- LLVM.NumberOfElements a ~ LLVM.NumberOfElements i) =>+ (IsFloating a, LLVM.IsInteger i, LLVM.ShapeOf a ~ LLVM.ShapeOf i) => Value a -> CodeGenFunction r (Value i, Value a) splitFraction x = do n <- LLVM.fptoint x@@ -414,7 +411,7 @@ limitShape :: (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm, IsFloating t, SoV.Real t,- LLVM.NumberOfElements t ~ LLVM.NumberOfElements i,+ LLVM.ShapeOf t ~ LLVM.ShapeOf i, MakeValueTuple i, ValueTuple i ~ Value i, Ring.C i, LLVM.IsInteger i, SoV.IntegerConstant i, Storable i, Memory.FirstClass i, Memory.Stored i ~ im, IsSized im,@@ -453,7 +450,7 @@ limitShapeSignal :: (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm, IsFloating t,- LLVM.NumberOfElements t ~ LLVM.NumberOfElements i,+ LLVM.ShapeOf t ~ LLVM.ShapeOf i, MakeValueTuple i, ValueTuple i ~ Value i, Ring.C i, LLVM.IsInteger i, SoV.IntegerConstant i, Storable i, Memory.FirstClass i, Memory.Stored i ~ im, IsSized im,@@ -516,7 +513,7 @@ _shapeLimits :: (Ip.C nodesLeap, Ip.C nodesStep,- IsFloating t, LLVM.NumberOfElements t ~ D1) =>+ IsFloating t, LLVM.ShapeOf t ~ LLVM.ScalarShape) => Ip.Margin (nodesLeap (nodesStep value)) -> Value.T (Value Word32) -> Value.T (Value t) ->@@ -653,10 +650,10 @@ (\_ d t0 -> let (t1, cum) = unzip $ Value.lift2 Vector.cumulate t0 d {-- Vector.select can be replaced by (??)+ LLVM.select can be replaced by (??) once vector select is implemented by LLVM. -}- in (wrap (Value.lift3 Vector.select) cum, t1))+ in (wrap (Value.lift3 LLVM.select) cum, t1)) id (return ()) start <<^ (\(Serial.Cons v) -> v)
src/Synthesizer/LLVM/CausalParameterized/Process.hs view
@@ -119,7 +119,6 @@ IsSized, IsConst, IsArithmetic, IsFloating, ) import qualified Type.Data.Num.Decimal as TypeNum-import Type.Data.Num.Decimal (D1, ) import qualified Control.Category as Cat import Control.Monad.Trans.State (runState, )@@ -508,7 +507,7 @@ delayControlledInterpolated :: (Interpolation.C nodes, Storable vh, MakeValueTuple vh, ValueTuple vh ~ v, Memory.C v,- IsFloating a, LLVM.NumberOfElements a ~ TypeNum.D1) =>+ IsFloating a, LLVM.ShapeOf a ~ LLVM.ScalarShape) => (forall r. Interpolation.T r nodes (Value a) v) -> Param.T p vh -> Param.T p Int -> T p (Value a, v) v delayControlledInterpolated ip initial maxTime =@@ -546,7 +545,7 @@ T p al al comb gain time = loopZero (mix >>> (Cat.id &&&- (delayZero (subtract 1 time) >>> amplify gain)))+ (delayZero (time-1) >>> amplify gain))) combStereo :: (A.PseudoRing al,@@ -555,7 +554,7 @@ T p (Stereo.T al) (Stereo.T al) combStereo gain time = loopZero (mix >>> (Cat.id &&&- (delayZero (subtract 1 time) >>> amplifyStereo gain)))+ (delayZero (time-1) >>> amplifyStereo gain))) {- | Example: apply a stereo reverb to a mono sound.@@ -585,7 +584,7 @@ reverb :: (Random a, SoV.PseudoModule a, SoV.Scalar a ~ s,- IsFloating s, SoV.IntegerConstant s, LLVM.NumberOfElements s ~ D1,+ IsFloating s, SoV.IntegerConstant s, LLVM.ShapeOf s ~ LLVM.ScalarShape, MakeValueTuple a, ValueTuple a ~ Value a, Storable a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, RandomGen g) =>
src/Synthesizer/LLVM/CausalParameterized/ProcessPacked.hs view
@@ -33,9 +33,7 @@ import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) import qualified LLVM.Core as LLVM-import LLVM.Core- (CodeGenFunction, Value,- IsSized, IsArithmetic, IsPrimitive, )+import LLVM.Core (CodeGenFunction, Value, IsSized, IsArithmetic, IsPrimitive) import qualified Type.Data.Num.Decimal as TypeNum
src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs view
@@ -241,12 +241,8 @@ maybe (c, (stateA, stateB)) composeNext onFail stopA stopB nextA nextB (paramA, paramB) (localA, localB) a (sa0,sb0) = do- (b,sa1) <-- onFail (stopB paramB sb0) $- nextA paramA localA a sa0- (c,sb1) <-- onFail (stopA paramA sa1) $- nextB paramB localB b sb0+ (b,sa1) <- onFail (stopB paramB sb0) $ nextA paramA localA a sa0+ (c,sb1) <- onFail (stopA paramA sa1) $ nextB paramB localB b sb0 return (c, (sa1,sb1)) composeStart ::
src/Synthesizer/LLVM/EventIterator.hs view
@@ -32,16 +32,10 @@ foreign import ccall "&nextConstant"- nextCallBack ::- FunPtr (- StablePtr (T a) ->- MemoryPtr a -> IO Word32- )+ nextCallBack :: FunPtr (StablePtr (T a) -> MemoryPtr a -> IO Word32) foreign export ccall "nextConstant"- next ::- StablePtr (T a) ->- MemoryPtr a -> IO Word32+ next :: StablePtr (T a) -> MemoryPtr a -> IO Word32 {- |@@ -60,13 +54,10 @@ filter ((/=0) . snd) $ EventList.toPairList evs) -dispose ::- StablePtr (T a) -> IO ()+dispose :: StablePtr (T a) -> IO () dispose = freeStablePtr <=< DebugStable.trace "dispose" -next ::- StablePtr (T a) ->- MemoryPtr a -> IO Word32+next :: StablePtr (T a) -> MemoryPtr a -> IO Word32 next stable eventPtr = DebugStable.trace "next" stable >>= deRefStablePtr >>= \state ->
src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs view
@@ -50,9 +50,7 @@ r' <- phis bb r i' <- phis bb i return (Parameter r' i')- addPhis bb- (Parameter r i)- (Parameter r' i') = do+ addPhis bb (Parameter r i) (Parameter r' i') = do addPhis bb r r' addPhis bb i i'
src/Synthesizer/LLVM/Frame/Binary.hs view
@@ -16,7 +16,7 @@ toCanonical ::- (LLVM.NumberOfElements real ~ LLVM.NumberOfElements int,+ (LLVM.ShapeOf real ~ LLVM.ShapeOf int, LLVM.IsFloating real, SoV.IntegerConstant real, LLVM.IsInteger int, Bounded int, ToInteger.C int) => LLVM.Value int -> LLVM.CodeGenFunction r (LLVM.Value real)
src/Synthesizer/LLVM/Frame/SerialVector.hs view
@@ -626,8 +626,6 @@ -} class (TypeNum.Positive (Size valueTuple)) => Sized valueTuple where type Size valueTuple :: *- serialSize :: valueTuple -> Size valueTuple- serialSize _ = error "serial size is a type number and has no value" {- | Basic LLVM types are all counted as scalar values, even LLVM Vectors.
src/Synthesizer/LLVM/Frame/Stereo.hs view
@@ -111,7 +111,7 @@ {- instance- (Memory l s, LLVM.IsSized s ss) =>+ (Memory l s) => Memory (Stereo.T l) (LLVM.Struct (s, (s, ()))) where load ptr = liftM2 Stereo.cons
src/Synthesizer/LLVM/Frame/StereoInterleaved.hs view
@@ -47,8 +47,7 @@ import LLVM.Extra.Class (Undefined, undefTuple, MakeValueTuple, valueTupleOf, )-import LLVM.Core- (Vector, IsSized, SizeOf, )+import LLVM.Core (Vector, IsSized, SizeOf, ) import LLVM.Util.Loop (Phi, phis, addPhis, ) import qualified Type.Data.Num.Decimal as TypeNum
src/Synthesizer/LLVM/MIDI/BendModulation.hs view
@@ -47,17 +47,14 @@ LLVM.CmpRet (BM.T a) (BM.T b) where -} -instance Class.MakeValueTuple h =>- Class.MakeValueTuple (BM.T h) where+instance Class.MakeValueTuple h => Class.MakeValueTuple (BM.T h) where type ValueTuple (BM.T h) = BM.T (Class.ValueTuple h) valueTupleOf = Class.valueTupleOfFunctor type Struct a = LLVM.Struct (a, (a, ())) -memory ::- (Memory.C l) =>- Memory.Record r (Struct (Memory.Struct l)) (BM.T l)+memory :: (Memory.C l) => Memory.Record r (Struct (Memory.Struct l)) (BM.T l) memory = liftA2 BM.Cons (Memory.element BM.bend TypeNum.d0)
src/Synthesizer/LLVM/Parameterized/Signal.hs view
@@ -62,6 +62,7 @@ run, runChunky, runChunkyPattern,+ runChunkyPlugged, -- for testing noiseCoreAlt,@@ -72,6 +73,7 @@ import qualified Synthesizer.LLVM.Simple.Signal as Sig import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Plug.Output as POut import qualified Synthesizer.LLVM.Interpolation as Interpolation import qualified Synthesizer.LLVM.ConstantPiece as Const import qualified Synthesizer.LLVM.Parameter as Param@@ -118,7 +120,7 @@ import Control.Monad.HT ((<=<), ) import Control.Monad (when, ) import Control.Arrow ((^<<), )-import Control.Applicative (liftA2, liftA3, pure, (<$>), )+import Control.Applicative (Applicative, liftA2, liftA3, pure, (<$>), ) import Control.Functor.HT (void, ) import qualified Algebra.Transcendental as Trans@@ -158,8 +160,7 @@ {- | @tail empty@ generates the empty signal. -}-tail ::- T p a -> T p a+tail :: T p a -> T p a tail (Cons next alloca start stop createIOContext deleteIOContext) = Cons next alloca@@ -173,9 +174,7 @@ createIOContext deleteIOContext -drop ::- Param.T p Int ->- T p a -> T p a+drop :: Param.T p Int -> T p a -> T p a drop n (Cons next alloca start stop createIOContext deleteIOContext) = Param.with (Param.word32 n) $ \getN valueN -> Cons next@@ -358,8 +357,7 @@ 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+ map wave waveParam $ osciCore phase freq osciSimple :: (Storable t, MakeValueTuple t, ValueTuple t ~ tl,@@ -477,7 +475,7 @@ -} noise :: (Algebraic.C a, IsFloating a, IsConst a,- LLVM.NumberOfElements a ~ TypeNum.D1,+ LLVM.ShapeOf a ~ LLVM.ScalarShape, Memory.C (Value a), MakeValueTuple a, ValueTuple a ~ (Value a), Storable a) => Param.T p Word32 ->@@ -497,7 +495,7 @@ and thus we use it, since the arguments are below 2^31. -} int31tofp ::- (IsFloating a, LLVM.NumberOfElements a ~ TypeNum.D1) =>+ (IsFloating a, LLVM.ShapeOf a ~ LLVM.ScalarShape) => Value Word32 -> CodeGenFunction r (Value a) int31tofp = LLVM.inttofp <=<@@ -591,6 +589,24 @@ Const.flatten . Const.lazySize ++createFunction ::+ (Functor genMod, EE.ExecutionFunction fun) =>+ Exec.Importer fun -> genMod (Function fun) ->+ Compose genMod EE.EngineAccess fun+createFunction importer modul =+ Compose $ EE.getExecutionFunction importer <$> modul++createFinalizer ::+ (Applicative genMod, EE.ExecutionFunction fun) =>+ Exec.Importer fun -> genMod (Function fun) ->+ Compose genMod EE.EngineAccess (EE.ExecutionEngine, fun)+createFinalizer importer modul =+ liftA2 (,)+ (Compose $ pure EE.getEngine)+ (createFunction importer modul)++ foreign import ccall safe "dynamic" derefFillPtr :: Exec.Importer (Ptr param -> Word32 -> Ptr a -> IO Word32) @@ -626,8 +642,7 @@ forall parameters struct paramStruct. (Storable parameters, LLVM.IsType struct,- LLVM.IsType paramStruct,- IsSized paramStruct) =>+ LLVM.IsType paramStruct, IsSized paramStruct) => CodeGenModule (Function (Ptr paramStruct -> Word32 -> Ptr struct -> IO Word32)) -> parameters ->@@ -670,18 +685,14 @@ IO (Int -> p -> SV.Vector a) run (Cons next alloca start stop createIOContext deleteIOContext) = do -- this compiles once and is much faster than simpleFunction- fill <-- Exec.compileModule $- Compose $- (EE.getExecutionFunction derefFillPtr- <$> moduleFill next alloca start stop)+ let modul = moduleFill next alloca start stop+ fill <- Exec.compileModule $ createFunction derefFillPtr modul return $ \len p -> Unsafe.performIO $ bracket (createIOContext p) (deleteIOContext . fst) $ \ (_,params) -> do- when False $ void $- debugMain (moduleFill next alloca start stop) params+ when False $ void $ debugMain modul params SVB.createAndTrim len $ \ ptr -> Alloc.with params $ \paramPtr ->@@ -708,84 +719,101 @@ Exec.Importer (Ptr contextStateStruct -> Word32 -> Ptr struct -> IO Word32) -moduleChunky ::+moduleStart ::+ (Memory.C parameters, Memory.Struct parameters ~ paramStruct,+ Memory.C context, Memory.C state,+ Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>+ (forall r. parameters -> CodeGenFunction r (context, state)) ->+ CodeGenModule (Function (Ptr paramStruct -> IO (Ptr contextStateStruct)))+moduleStart start =+ Exec.createLLVMFunction "startsignal" $+ \paramPtr -> do+ pptr <- LLVM.malloc+ flip Memory.store pptr . mapSnd Maybe.just+ =<< start =<< Memory.load paramPtr+ ret pptr++moduleStop ::+ (Memory.C context, Memory.C state,+ Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>+ (forall r. context -> state -> CodeGenFunction r ()) ->+ CodeGenModule (Function (Ptr contextStateStruct -> IO ()))+moduleStop stop =+ Exec.createLLVMFunction "stopsignal" $+ \contextStatePtr -> do+ (c,ms) <- Memory.load contextStatePtr+ Maybe.for ms $ stop c+ LLVM.free contextStatePtr+ ret ()++moduleNext :: (Memory.C value, Memory.Struct value ~ struct,- Memory.C parameters, Memory.Struct parameters ~ paramStruct, Memory.C context, Memory.C state, Memory.Struct (context, Maybe.T state) ~ contextStateStruct) => (forall r z. (Loop.Phi z) => context -> local -> state -> MaybeCont.T r z (value, state)) -> (forall r. CodeGenFunction r local) ->- (forall r.- parameters -> CodeGenFunction r (context, state)) ->- (forall r.- context -> state -> CodeGenFunction r ()) -> CodeGenModule- (Function (Ptr paramStruct -> IO (Ptr contextStateStruct)),- Function (Ptr contextStateStruct -> IO ()),- Function (Ptr contextStateStruct ->- Word32 -> Ptr struct -> IO Word32))-moduleChunky next alloca start stop = liftA3 (,,)- (Exec.createLLVMFunction "startsignal" $- \paramPtr -> do- pptr <- LLVM.malloc- flip Memory.store pptr . mapSnd Maybe.just =<< start =<< Memory.load paramPtr- ret pptr)- (Exec.createLLVMFunction "stopsignal" $- \ contextStatePtr -> do- (c,ms) <- Memory.load contextStatePtr- Maybe.for ms $ stop c- LLVM.free contextStatePtr- ret ())- (Exec.createLLVMFunction "fillsignal" $- \ contextStatePtr loopLen ptr -> do- (context, msInit) <- Memory.load contextStatePtr- local <- alloca- (pos,msExit) <-- Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->- MaybeCont.arrayLoop loopLen ptr sInit $ \ ptri s0 -> do- (y,s1) <- next context local s0- MaybeCont.lift $ Memory.store y ptri- return s1- sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())- Memory.store msExit sptr- ret pos)+ (Function (Ptr contextStateStruct -> Word32 -> Ptr struct -> IO Word32))+moduleNext next alloca =+ Exec.createLLVMFunction "fillsignal" $+ \contextStatePtr loopLen ptr -> do+ (context, msInit) <- Memory.load contextStatePtr+ local <- alloca+ (pos,msExit) <-+ Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->+ MaybeCont.arrayLoop loopLen ptr sInit $ \ ptri s0 -> do+ (y,s1) <- next context local s0+ MaybeCont.lift $ Memory.store y ptri+ return s1+ sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())+ Memory.store msExit sptr+ ret pos -compileChunky ::- (Memory.C value, Memory.Struct value ~ struct,- Memory.C parameters, Memory.Struct parameters ~ paramStruct,- Memory.C context, Memory.C state,- Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>++moduleNextPlugged ::+ (Memory.C context, Memory.C state,+ Memory.Struct (context, Maybe.T state) ~ contextStateStruct,+ Undefined stateOut, Loop.Phi stateOut,+ Memory.C paramValueOut, Memory.Struct paramValueOut ~ paramStructOut) => (forall r z. (Loop.Phi z) => context -> local -> state -> MaybeCont.T r z (value, state)) -> (forall r. CodeGenFunction r local) -> (forall r.- parameters -> CodeGenFunction r (context, state)) ->+ paramValueOut ->+ value -> stateOut -> LLVM.CodeGenFunction r stateOut) -> (forall r.- context -> state -> CodeGenFunction r ()) ->- IO (Ptr paramStruct -> IO (Ptr contextStateStruct),- Exec.Finalizer contextStateStruct,- Ptr contextStateStruct -> Word32 -> Ptr struct -> IO Word32)-compileChunky next alloca start stop =- Exec.compileModule $- Compose- ((\(startF, stopF, nextF) ->- liftA3 (,,)- (EE.getExecutionFunction derefStartPtr startF)- (liftA2 (,) EE.getEngine $- EE.getExecutionFunction derefStopPtr stopF)- (EE.getExecutionFunction derefChunkPtr nextF))- <$> moduleChunky next alloca start stop)+ paramValueOut ->+ LLVM.CodeGenFunction r stateOut) ->+ CodeGenModule+ (Function+ (Ptr contextStateStruct -> Word32 -> Ptr paramStructOut -> IO Word32))+moduleNextPlugged next alloca nextOut startOut =+ Exec.createLLVMFunction "fillsignal" $+ \contextStatePtr loopLen outPtr -> do+ (context, msInit) <- Memory.load contextStatePtr+ outParam <- Memory.load outPtr+ outInit <- startOut outParam+ local <- alloca+ (pos,msExit) <-+ Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->+ MaybeCont.fixedLengthLoop loopLen (sInit, outInit) $+ \ (s0,out0) -> do+ (y,s1) <- next context local s0+ out1 <- MaybeCont.lift $ nextOut outParam y out0+ return (s1, out1)+ sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())+ Memory.store (fmap fst msExit) sptr+ ret pos debugChunkyMain :: forall parameters struct paramStruct contextStateStruct. (Storable parameters, LLVM.IsType struct, LLVM.IsType contextStateStruct,- LLVM.IsType paramStruct,- IsSized paramStruct) =>+ LLVM.IsType paramStruct, IsSized paramStruct) => CodeGenModule (Function (Ptr paramStruct -> IO (Ptr contextStateStruct)), Function (Ptr contextStateStruct -> IO ()),@@ -841,13 +869,28 @@ If the pattern is shorter than the generated signal this means that the signal is shortened. -}-runChunkyPattern ::+runChunkyPattern, _runChunkyPattern :: (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => T p value -> IO (SVP.LazySize -> p -> SVL.Vector a)+_runChunkyPattern =+ fmap (\f size -> SVL.fromChunks . f size) .+ flip runChunkyPatternPlugged POut.deflt+ runChunkyPattern (Cons next alloca start stop createIOContext deleteIOContext) = do- (startFunc, stopFunc, fill) <- compileChunky next alloca start stop++ let startF = moduleStart start+ let stopF = moduleStop stop+ let nextF = moduleNext next alloca++ (startFunc, stopFunc, fill) <-+ Exec.compileModule $+ liftA3 (,,)+ (createFunction derefStartPtr startF)+ (createFinalizer derefStopPtr stopF)+ (createFunction derefChunkPtr nextF)+ return $ \ lazysize p -> SVL.fromChunks $ Unsafe.performIO $ do (ioContext, param) <- createIOContext p@@ -860,7 +903,7 @@ DebugSt.dump "param" param when False $ void $- debugChunkyMain (moduleChunky next alloca start stop) param+ debugChunkyMain (liftA3 (,,) startF stopF nextF) param statePtr <- ForeignPtr.newParam stopFunc startFunc param ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext)@@ -885,12 +928,74 @@ else go rest) go (Chunky.toChunks lazysize) -runChunky ::+runChunkyPatternPlugged ::+ T p value ->+ POut.T value chunk ->+ IO (SVP.LazySize -> p -> [chunk])+runChunkyPatternPlugged+ (Cons next alloca start stop createIOContext deleteIOContext)+ (POut.Cons nextOut startOut createOut deleteOut) = do++ (startFunc, stopFunc, fill) <-+ Exec.compileModule $+ liftA3 (,,)+ (createFunction derefStartPtr $ moduleStart start)+ (createFinalizer derefStopPtr $ moduleStop stop)+ (createFunction derefChunkPtr $+ moduleNextPlugged next alloca nextOut startOut)++ return $+ \ lazysize p -> Unsafe.performIO $ do+ (ioContext, param) <- createIOContext p++ statePtr <- ForeignPtr.newParam stopFunc startFunc param+ ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext)++ let go cs =+ Unsafe.interleaveIO $+ case cs of+ [] -> return []+ SVL.ChunkSize maximumSize : rest -> do+ (contextOut,paramOut) <- createOut maximumSize+ actualSize <-+ fmap fromIntegral $+ Alloc.with paramOut $ \outptr ->+ withForeignPtr statePtr $ \sptr ->+ fill sptr+ (fromIntegral maximumSize)+ (Memory.castTuplePtr outptr)+ when (fromIntegral actualSize > maximumSize) $+ error $ "Parametrized.Signal: " +++ "output size " ++ show actualSize +++ " > input size " ++ show maximumSize+ v <- deleteOut actualSize contextOut+ touchForeignPtr ioContextPtr+ (if actualSize > 0+ then fmap (v:)+ else id) $+ (if actualSize < maximumSize+ then return []+ else go rest)+ go (Chunky.toChunks lazysize)++runChunky, _runChunky :: (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => 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++_runChunky =+ fmap (\f size -> SVL.fromChunks . f size) .+ flip runChunkyPlugged POut.deflt++runChunkyPlugged ::+ T p value ->+ POut.T value chunk ->+ IO (SVL.ChunkSize -> p -> [chunk])+runChunkyPlugged sig plug =+ flip fmap (runChunkyPatternPlugged sig plug) $ \f size p -> f (Chunky.fromChunks (repeat size)) p {- |
src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs view
@@ -138,10 +138,7 @@ (paramB -> m (contextB, stateB)) -> (paramA, paramB) -> m ((contextA, contextB), (stateA, stateB)) combineStart startA startB (paramA, paramB) =- liftM2- (\(ca,sa) (cb,sb) -> ((ca,cb), (sa,sb)))- (startA paramA)- (startB paramB)+ liftM2 Sig.zipPair (startA paramA) (startB paramB) combineStop :: Monad m =>@@ -156,17 +153,14 @@ (p -> m (ioContextA, contextA)) -> (p -> m (ioContextB, contextB)) -> p -> m ((ioContextA, ioContextB), (contextA, contextB))-combineCreate createIOContextA createIOContextB p = do- (ca,paramA) <- createIOContextA p- (cb,paramB) <- createIOContextB p- return ((ca,cb), (paramA,paramB))+combineCreate createIOContextA createIOContextB p =+ liftM2 Sig.zipPair (createIOContextA p) (createIOContextB p) combineDelete :: (Monad m) => (ca -> m ()) -> (cb -> m ()) -> (ca, cb) -> m () combineDelete deleteIOContextA deleteIOContextB (ca,cb) =- deleteIOContextA ca >>- deleteIOContextB cb+ deleteIOContextA ca >> deleteIOContextB cb @@ -352,8 +346,7 @@ Param.T p ph -> Param.T p a -> T p al iterate f param initial = simple- (\pl al0 ->- MaybeCont.lift $ fmap (\al1 -> (al0,al1)) (f pl al0))+ (\pl al0 -> MaybeCont.lift $ fmap (\al1 -> (al0,al1)) (f pl al0)) return (param &&& initial)
src/Synthesizer/LLVM/Plug/Input.hs view
@@ -4,7 +4,18 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}-module Synthesizer.LLVM.Plug.Input where+module Synthesizer.LLVM.Plug.Input (+ T(..),+ Default(..),+ rmap,+ split,+ fanout,+ lazySize,+ ignore,+ storableVector,+ piecewiseConstant,+ controllerSet,+ ) where import qualified Synthesizer.Zip as Zip @@ -54,21 +65,21 @@ via an instance of 'Synthesizer.Generic.Cut.Read'. -} data T a b =- forall state ioContext paramTuple.- (Storable paramTuple,- MakeValueTuple paramTuple,- Memory.C (ValueTuple paramTuple),+ forall state ioContext parameters.+ (Storable parameters,+ MakeValueTuple parameters,+ Memory.C (ValueTuple parameters), Memory.C state) => Cons (forall r.- ValueTuple paramTuple ->+ ValueTuple parameters -> state -> LLVM.CodeGenFunction r (b, state)) -- compute next value (forall r.- ValueTuple paramTuple ->+ ValueTuple parameters -> LLVM.CodeGenFunction r state) -- initial state- (a -> IO (ioContext, paramTuple))+ (a -> IO (ioContext, parameters)) {- initialization from IO monad This is called once input chunk. This will be run within Unsafe.performIO,@@ -182,28 +193,33 @@ Memory.C value) => T (EventListBT.T NonNegW.Int a) value piecewiseConstant =- case rmap (uncurry Zip.Cons .- mapPair (SV.pack . map ((fromIntegral :: Int -> Word32) .- NonNegW.toNumber),- SV.pack) .- swap . unzip . EventListBT.toPairList) $- fmap (uncurry Const.Cons) $- split storableVector storableVector of- Cons next start create delete -> Cons- (\param state0 -> do- (Const.Cons length1 y1, s1) <-- C.whileLoopShared state0- (\(Const.Cons len _y, s) ->- (A.cmp LLVM.CmpEQ len Class.zeroTuple,- next param s))- length2 <- A.dec length1- return (y1, (Const.Cons length2 y1, s1)))- (\param ->- fmap ((,) (Const.Cons Class.zeroTuple Class.undefTuple)) $- start param)- create delete+ expandConstantPieces $+ rmap (uncurry Zip.Cons .+ mapPair+ (SV.pack .+ map ((fromIntegral :: Int -> Word32) . NonNegW.toNumber),+ SV.pack) .+ swap . unzip . EventListBT.toPairList) $+ fmap (uncurry Const.Cons) $+ split storableVector storableVector +expandConstantPieces ::+ (Memory.C value) => T events (Const.T value) -> T events value+expandConstantPieces (Cons next start create delete) = Cons+ (\param state0 -> do+ (Const.Cons length1 y1, s1) <-+ C.whileLoopShared state0+ (\(Const.Cons len _y, s) ->+ (A.cmp LLVM.CmpEQ len Class.zeroTuple,+ next param s))+ length2 <- A.dec length1+ return (y1, (Const.Cons length2 y1, s1)))+ (\param ->+ fmap ((,) (Const.Cons Class.zeroTuple Class.undefTuple)) $+ start param)+ create delete + {- | Return an Array and not a pointer to an array, in order to forbid writing to the array.@@ -214,56 +230,70 @@ Memory.FirstClass a, LLVM.IsSized a, LLVM.IsSized (Memory.Stored a)) => Proxy n -> T (PCS.T Int a) (LLVM.Value (LLVM.Array n a)) controllerSet pn =- case storableVector of- Cons next start create delete -> Cons- (\((arrPtr, _), param) state0 -> do- (length2, s2) <-- C.whileLoopShared state0- (\(len0, s0) ->- (A.cmp LLVM.CmpEQ len0 Class.zeroTuple,- do ((len1, (i,a)), s1) <- next param s0- LLVM.store a =<<- LLVM.getElementPtr arrPtr (i, ())- return (len1, s1)))- length3 <- A.dec length2- arr <- LLVM.load =<< LLVM.bitcast arrPtr- return (arr, (length3, s2)))- (\((_, initialTime), param) -> do- state <- start param- return (initialTime, state))+ controllerSetFromSV pn $+ split storableVector $ split storableVector storableVector - (\pcs ->- EventListMT.switchTimeL- (\initialTime bt -> do- (context, param) <-- create- (SV.pack .- map (\((i,a),len) ->- (fromIntegral len :: Word32,- (fromIntegral i :: Word32, a))) .- EventListBT.toPairList $- bt)+controllerSetFromSV ::+ (TypeNum.Natural n,+ Storable a, MakeValueTuple a, ValueTuple a ~ LLVM.Value a,+ Memory.FirstClass a, LLVM.IsSized a, LLVM.IsSized (Memory.Stored a)) =>+ Proxy n ->+ T (Zip.T (SV.Vector Word32) (Zip.T (SV.Vector Word32) (SV.Vector a)))+ (LLVM.Value Word32, (LLVM.Value Word32, LLVM.Value a)) ->+ T (PCS.T Int a) (LLVM.Value (LLVM.Array n a))+controllerSetFromSV pn (Cons next start create delete) = Cons+ (\((arrPtr, _), param) state0 -> do+ (length2, s2) <-+ C.whileLoopShared state0+ (\(len0, s0) ->+ (A.cmp LLVM.CmpEQ len0 Class.zeroTuple,+ do ((len1, (i,a)), s1) <- next param s0+ LLVM.store a =<<+ LLVM.getElementPtr arrPtr (i, ())+ return (len1, s1)))+ length3 <- A.dec length2+ arr <- LLVM.load =<< LLVM.bitcast arrPtr+ return (arr, (length3, s2)))+ (\((_, initialTime), param) -> do+ state <- start param+ return (initialTime, state)) - -- FIXME: handle memory exhaustion- let n = TypeNum.integralFromProxy pn- arr <- Array.mallocArray n- flip mapM_ (Map.toList $ PCS.initial pcs) $ \(i,a) ->- if i >= n- then error "Plug.Input.controllerSet: array too small"- else pokeElemOff arr i a+ (\pcs ->+ EventListMT.switchTimeL+ (\initialTime bt -> do+ (context, param) <-+ create+ (uncurry Zip.Cons .+ mapPair+ (SV.pack,+ uncurry Zip.Cons . mapPair (SV.pack, SV.pack). unzip) .+ unzip .+ map (\((i,a),len) ->+ (fromIntegral len :: Word32,+ (fromIntegral i :: Word32, a))) .+ EventListBT.toPairList $+ bt) - return- ((arr, context),- ((arr, fromIntegral initialTime :: Word32), param)))- {-- It would be more elegant,- if we could pass Arrays around just like Vectors.+ -- FIXME: handle memory exhaustion+ let n = TypeNum.integralFromProxy pn+ arr <- Array.mallocArray n+ flip mapM_ (Map.toList $ PCS.initial pcs) $ \(i,a) ->+ if i >= n+ then error "Plug.Input.controllerSet: array too small"+ else pokeElemOff arr i a - return (context, ((sampleArray (\i -> maybe Class.undefTuple Class.valueTupleOf $ Map.lookup i (PCS.initial pcs)), time), param)))- -}- (EventListTT.flatten (PCS.stream pcs)))- (\(arr, context) ->- Alloc.free arr >> delete context)+ return+ ((arr, context),+ ((arr, fromIntegral initialTime :: Word32), param)))+ {-+ It would be more elegant,+ if we could pass Arrays around just like Vectors.++ return (context, ((sampleArray (\i -> maybe Class.undefTuple Class.valueTupleOf $ Map.lookup i (PCS.initial pcs)), time), param)))+ -}+ (EventListTT.flatten (PCS.stream pcs)))+ (\(arr, context) ->+ Alloc.free arr >> delete context) {- We might provide a plug that maps from a sequence of time-stamped controller events
src/Synthesizer/LLVM/Plug/Output.hs view
@@ -29,21 +29,21 @@ data T a b =- forall state ioContext paramTuple.- (Storable paramTuple,- Class.MakeValueTuple paramTuple,- Memory.C (Class.ValueTuple paramTuple),+ forall state ioContext parameters.+ (Storable parameters,+ Class.MakeValueTuple parameters,+ Memory.C (Class.ValueTuple parameters), Memory.C state) => Cons (forall r.- Class.ValueTuple paramTuple ->+ Class.ValueTuple parameters -> a -> state -> LLVM.CodeGenFunction r state) -- compute next value (forall r.- Class.ValueTuple paramTuple ->+ Class.ValueTuple parameters -> LLVM.CodeGenFunction r state) -- initial state- (Int -> IO (ioContext, paramTuple))+ (Int -> IO (ioContext, parameters)) {- initialization from IO monad This is called once per output chunk with the number of input samples.
src/Synthesizer/LLVM/Random.hs view
@@ -9,21 +9,16 @@ 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 qualified LLVM.Core.Guided as Guided import LLVM.Core (CodeGenFunction, Value, Vector,- zext, trunc, lshr, value, valueOf,- undef, constOf, constVector, bitcast, )+ zext, trunc, lshr, valueOf) import qualified LLVM.Core as LLVM import qualified Type.Data.Num.Decimal as TypeNum import qualified Data.NonEmpty.Class as NonEmptyC-import qualified Data.Empty as Empty-import Data.NonEmpty ((!:), ) import Data.Function.HT (nest, ) import Data.Int (Int32, )@@ -132,149 +127,7 @@ vector64 :: Value (Vector n Word64) -> Value (Vector n Word64) vector64 = id -nextVector ::- (TypeNum.Positive 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 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 =<< shuffleHoles s 0 2-- (lowOdd, highOdd) <- mulAndReduce =<< shuffleHoles s 1 3-- 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- Vector.shuffleMatchPlain2 even4x32 odd4x32- (constVector $ fmap constOf $ 0 !: 4 !: 2 !: 6 !: Empty.Cons)-- {--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- (low0, high0) <-- splitVector31to64 =<<- muludq (prepConstFactor (vectorParameter n)) =<<- shuffleHoles s 0 1- -- 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 $ fmap constOf $ 0!:2!:Empty.Cons)-- 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- LLVM.shufflevector- (result :: Value (Vector TypeNum.D4 Word32))- (LLVM.value LLVM.undef)- (constVector $ fmap constOf $ 0!:2!:Empty.Cons)--prepConstFactor :: Word32 -> Value (Vector TypeNum.D4 Word32)-prepConstFactor x =- value $ constVector $- constOf x !: undef !: constOf x !: undef !: Empty.Cons--shuffleHoles ::- (TypeNum.Positive n) =>- Value (Vector n Word32) ->- Word32 -> Word32 ->- CodeGenFunction r (Value (Vector TypeNum.D4 Word32))-shuffleHoles s j k =- LLVM.shufflevector s (value undef)- (constVector $ constOf j !: undef !: constOf k !: undef !: Empty.Cons)--splitVector31to64 ::- (TypeNum.Positive 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@@ -317,11 +170,11 @@ But in the end we will need at least the same number of multiplications as in the approach that is implemented here. -}-nextVectorGeneric ::+nextVector :: (TypeNum.Positive n) => Value (Vector n Word32) -> CodeGenFunction r (Value (Vector n Word32))-nextVectorGeneric s = do+nextVector s = do {- It seems that LLVM-2.6 on x86 does not make use of the fact, that the upper doublewords are zero.@@ -329,14 +182,14 @@ -} (low0, high0) <- splitVector31 =<<- Vector.umul32to64 (SoV.replicateOf (vectorParameter (Vector.size s))) s+ 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+ umul32to64 (SoV.replicateOf fac) high0 subtractIfPossible (SoV.replicateOf modulus) =<< A.add low1@@ -373,7 +226,7 @@ CodeGenFunction r (Value (Vector n Int32)) selectNonNegativeGeneric x y = do b <- A.cmp LLVM.CmpGE x A.zero- Vector.select b x y+ LLVM.select b x y splitVector31 ::@@ -396,4 +249,14 @@ nextVector64 s = Vector.map trunc =<< flip A.irem (SoV.replicateOf modulus) =<<- Vector.umul32to64 (SoV.replicateOf (vectorParameter (Vector.size s))) s+ umul32to64 (SoV.replicateOf (vectorParameter (Vector.size s))) s++umul32to64 ::+ (TypeNum.Positive n) =>+ Value (Vector n Word32) ->+ Value (Vector n Word32) ->+ CodeGenFunction r (Value (Vector n Word64))+umul32to64 x y = do+ x64 <- Guided.ext Guided.vector x+ y64 <- Guided.ext Guided.vector y+ A.mul x64 y64
src/Synthesizer/LLVM/Simple/SignalPrivate.hs view
@@ -36,7 +36,6 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Numeric import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, ) import qualified Prelude as P@@ -162,14 +161,17 @@ zipWith f a b = map (uncurry f) $ liftA2 (,) a b +zipPair :: (a,b) -> (c,d) -> ((a,c),(b,d))+zipPair (a,b) (c,d) = ((a,c),(b,d))+ zip :: T a -> T b -> T (a,b) zip (Cons nextA allocaA startA createIOContextA deleteIOContextA) (Cons nextB allocaB startB createIOContextB deleteIOContextB) = Cons- (\(paramA, paramB) (localA, localB) (sa0,sb0) -> do- (a,sa1) <- nextA paramA localA sa0- (b,sb1) <- nextB paramB localB sb0- return ((a,b), (sa1,sb1)))+ (\(paramA, paramB) (localA, localB) (sa0,sb0) ->+ liftM2 zipPair+ (nextA paramA localA sa0)+ (nextB paramB localB sb0)) (liftM2 (,) allocaA allocaB) (combineStart startA startB) (combineCreate createIOContextA createIOContextB)@@ -181,24 +183,19 @@ (paramB -> m stateB) -> (paramA, paramB) -> m (stateA, stateB) combineStart startA startB (paramA, paramB) =- liftM2 (,)- (startA paramA)- (startB paramB)+ liftM2 (,) (startA paramA) (startB paramB) combineCreate :: Monad m => m (ioContextA, contextA) -> m (ioContextB, contextB) -> m ((ioContextA, ioContextB), (contextA, contextB))-combineCreate createIOContextA createIOContextB = do- (ca,paramA) <- createIOContextA- (cb,paramB) <- createIOContextB- return ((ca,cb), (paramA,paramB))+combineCreate createIOContextA createIOContextB =+ liftM2 zipPair createIOContextA createIOContextB combineDelete :: (Monad m) => (ca -> m ()) -> (cb -> m ()) -> (ca, cb) -> m () combineDelete deleteIOContextA deleteIOContextB (ca,cb) =- deleteIOContextA ca >>- deleteIOContextB cb+ deleteIOContextA ca >> deleteIOContextB cb instance Functor T where
src/Synthesizer/LLVM/Simple/Value.hs view
@@ -75,7 +75,7 @@ > osci :: > (RealRing.C (Value.T r t),-> IsFirstClass t, IsSized t size, IsFloating t,+> IsFirstClass t, IsFloating t, > IsPrimitive t, IsConst t) => > (forall r. Wave.T (Value.T r t) (Value.T r y)) -> > t -> t -> T (Value y)
src/Synthesizer/LLVM/Simple/Vanilla.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-} module Synthesizer.LLVM.Simple.Vanilla where import qualified Synthesizer.LLVM.Simple.Signal as Sig@@ -52,7 +51,7 @@ osciReg ::- (RealRing.C (Value.T (Value t)),+ (RealRing.C tv, tv ~ Value.T (Value t), Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, SoV.Fraction t, IsConst t, IsFirstClass y) =>@@ -64,7 +63,7 @@ Sig.iterate (SoV.incPhase freq) phase osciVal ::- (RealRing.C (Value.T (Value t)),+ (RealRing.C tv, tv ~ Value.T (Value t), Memory.FirstClass t, Memory.Stored t ~ tm, IsSized t, IsSized tm, SoV.Fraction t, IsConst t) => Wave.T (Value.T (Value t)) y ->
src/Synthesizer/LLVM/Storable/ChunkIterator.hs view
@@ -31,16 +31,10 @@ foreign import ccall "&nextChunk"- nextCallBack ::- FunPtr (- StablePtr (T a) ->- Ptr Word32 -> IO (MemoryPtr a)- )+ nextCallBack :: FunPtr (StablePtr (T a) -> Ptr Word32 -> IO (MemoryPtr a)) foreign export ccall "nextChunk"- next ::- StablePtr (T a) ->- Ptr Word32 -> IO (MemoryPtr a)+ next :: StablePtr (T a) -> Ptr Word32 -> IO (MemoryPtr a) new ::@@ -52,13 +46,10 @@ (newIORef (SVL.chunks sig)) (newIORef (error "first chunk must be fetched with nextChunk")) -dispose ::- StablePtr (T a) -> IO ()+dispose :: StablePtr (T a) -> IO () dispose = freeStablePtr -next ::- StablePtr (T a) ->- Ptr Word32 -> IO (MemoryPtr a)+next :: StablePtr (T a) -> Ptr Word32 -> IO (MemoryPtr a) next stable lenPtr = deRefStablePtr stable >>= \state -> case state of
synthesizer-llvm.cabal view
@@ -1,6 +1,7 @@+Cabal-Version: 2.2 Name: synthesizer-llvm-Version: 0.8.2.1-License: GPL+Version: 0.8.3+License: GPL-3.0-only License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de> Maintainer: Henning Thielemann <haskell@henning-thielemann.de>@@ -38,8 +39,8 @@ The module Synthesizer.LLVM.LAC2011 should be especially useful for an introduction. Stability: Experimental-Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.1-Cabal-Version: 1.14+Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3+Tested-With: GHC==8.6.5, GHC==8.8.1, GHC==8.10.1 Build-Type: Simple Extra-Source-Files: Changes.md@@ -57,7 +58,7 @@ default: False Source-Repository this- Tag: 0.8.2.1+ Tag: 0.8.3 Type: darcs Location: http://code.haskell.org/synthesizer/llvm/ @@ -68,8 +69,8 @@ Library Build-Depends:- llvm-extra >=0.8 && <0.9,- llvm-tf >=3.1 && <3.2,+ llvm-extra >=0.9 && <0.10,+ llvm-tf >=9.0 && <9.2, tfp >=1.0 && <1.1, vault >=0.3 && <0.4, synthesizer-core >=0.8 && <0.9,@@ -191,31 +192,60 @@ Synthesizer.LLVM.Simple.Vanilla -- Synthesizer.LLVM.Parameterized.Value +Library synthesizer-llvm-server+ If flag(buildExamples)+ Build-Depends:+ synthesizer-llvm,++ synthesizer-core,+ synthesizer-midi,+ midi,+ storablevector,+ numeric-prelude,+ non-negative,+ event-list,+ shell-utility >=0.0 && <0.2,+ pathtype,+ optparse-applicative >=0.11 && <0.16,+ containers,+ utility-ht,+ base++ Else+ Buildable: False++ Default-Language: Haskell98+ GHC-Options: -Wall+ If impl(ghc>=7.0)+ GHC-Options: -fwarn-unused-do-bind+ CPP-Options: -DNoImplicitPrelude=RebindableSyntax+ Default-Extensions: CPP+ Hs-Source-Dirs: server+ Exposed-Modules:+ Synthesizer.LLVM.Server.CausalPacked.Arrange+ Synthesizer.LLVM.Server.OptionCommon+ Synthesizer.LLVM.Server.Default+ Executable synthi-llvm-example If flag(buildExamples) Build-Depends:+ synthesizer-llvm-server, synthesizer-llvm, llvm-extra, llvm-tf, tfp, synthesizer-core,- synthesizer-midi >=0.6 && <0.7,- midi >=0.2.1 && <0.3,- storable-record >=0.0.2 && <0.1,- storable-tuple >=0.0.2 && <0.1,- sox >=0.2 && <0.3,- storablevector >=0.2.6 && <0.3,- numeric-prelude >=0.3 && <0.5,- non-negative >=0.1 && <0.2,- event-list >=0.1 && <0.2,+ sox,+ storablevector,+ numeric-prelude,+ non-negative,+ event-list, random,- containers >=0.1 && <0.7,- transformers, non-empty, utility-ht, pathtype,- base >=4 && <5+ base Else Buildable: False Default-Language: Haskell98@@ -229,11 +259,10 @@ GHC-Options: -fcontext-stack=1000 Else GHC-Options: -freduction-depth=1000- Hs-Source-Dirs: example, server+ Hs-Source-Dirs: example Main-Is: Synthesizer/LLVM/Test.hs Other-Modules: Synthesizer.LLVM.LAC2011- Synthesizer.LLVM.Server.Default Executable synthi-llvm-lndw If flag(buildExamples) && flag(alsa)@@ -244,17 +273,17 @@ llvm-tf, tfp, synthesizer-core,- synthesizer-midi >=0.6 && <0.7,- midi >=0.2.1 && <0.3,- storable-record >=0.0.2 && <0.1,- storable-tuple >=0.0.2 && <0.1,- sox >=0.2 && <0.3,- storablevector >=0.2.6 && <0.3,- numeric-prelude >=0.3 && <0.5,- non-negative >=0.1 && <0.2,- event-list >=0.1 && <0.2,+ synthesizer-midi,+ midi,+ storable-record,+ storable-tuple,+ sox,+ storablevector,+ numeric-prelude,+ non-negative,+ event-list, random,- containers >=0.1 && <0.7,+ containers, transformers, non-empty, utility-ht,@@ -262,7 +291,7 @@ synthesizer-alsa >=0.5 && <0.6, alsa-pcm >=0.6 && <0.7,- base >=4 && <5+ base Else Buildable: False Default-Language: Haskell98@@ -284,24 +313,20 @@ Executable synthi-llvm-alsa If flag(buildExamples) && flag(alsa) Build-Depends:+ synthesizer-llvm-server, synthesizer-llvm, - llvm-extra, llvm-tf,- tfp, synthesizer-core,- synthesizer-midi >=0.6 && <0.7,- midi >=0.2.1 && <0.3,- storable-record >=0.0.2 && <0.1,- storable-tuple >=0.0.2 && <0.1,- storablevector >=0.2.6 && <0.3,- numeric-prelude >=0.3 && <0.5,- non-negative >=0.1 && <0.2,- event-list >=0.1 && <0.2,- shell-utility >=0.0 && <0.1,- pathtype >=0.8 && <0.9,- optparse-applicative >=0.11 && <0.16,- containers >=0.1 && <0.7,+ synthesizer-midi,+ midi,+ storablevector,+ numeric-prelude,+ non-negative,+ event-list,+ pathtype,+ optparse-applicative,+ containers, transformers, utility-ht, @@ -309,7 +334,7 @@ midi-alsa >=0.2.1 && <0.3, alsa-seq >=0.6 && <0.7, alsa-pcm >=0.6 && <0.7,- base >=4 && <5+ base Else Buildable: False Default-Language: Haskell98@@ -325,7 +350,7 @@ GHC-Options: -fcontext-stack=1000 Else GHC-Options: -freduction-depth=1000- Hs-Source-Dirs: alsa, server+ Hs-Source-Dirs: alsa Main-Is: Synthesizer/LLVM/Server.hs Other-Modules: Synthesizer.LLVM.Server.Packed.Test@@ -334,41 +359,30 @@ Synthesizer.LLVM.Server.Scalar.Run Synthesizer.LLVM.Server.CausalPacked.Run Synthesizer.LLVM.Server.CausalPacked.Test- Synthesizer.LLVM.Server.CausalPacked.Arrange Synthesizer.LLVM.Server.ALSA Synthesizer.LLVM.Server.Option- Synthesizer.LLVM.Server.OptionCommon- Synthesizer.LLVM.Server.Default Executable synthi-llvm-jack If flag(buildExamples) && flag(jack) Build-Depends:+ synthesizer-llvm-server, synthesizer-llvm, jack >=0.7 && <0.8, - llvm-extra,- llvm-tf,- tfp, synthesizer-core,- synthesizer-midi >=0.6 && <0.7,- midi >=0.2.1 && <0.3,- storable-record >=0.0.2 && <0.1,- storable-tuple >=0.0.2 && <0.1,- storablevector >=0.2.6 && <0.3,- numeric-prelude >=0.3 && <0.5,- non-negative >=0.1 && <0.2,+ synthesizer-midi,+ midi,+ storablevector,+ non-negative, random, explicit-exception >=0.1.7 && <0.2,- event-list >=0.1 && <0.2,- shell-utility >=0.0 && <0.1,- pathtype >=0.8 && <0.9,- optparse-applicative >=0.11 && <0.16,- containers >=0.1 && <0.7,+ event-list,+ pathtype,+ optparse-applicative, transformers,- utility-ht, - base >=4 && <5+ base Else Buildable: False@@ -381,41 +395,27 @@ GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax Default-Extensions: CPP- Hs-Source-Dirs: jack, server+ Hs-Source-Dirs: jack Main-Is: Synthesizer/LLVM/Server/JACK.hs Other-Modules:- Synthesizer.LLVM.Server.CausalPacked.Arrange Synthesizer.LLVM.Server.Option- Synthesizer.LLVM.Server.OptionCommon- Synthesizer.LLVM.Server.Default Executable synthi-llvm-render If flag(buildExamples) Build-Depends:+ synthesizer-llvm-server, synthesizer-llvm, - llvm-extra,- llvm-tf,- tfp,- sox >=0.2.1 && <0.3,+ sox, synthesizer-core,- synthesizer-midi >=0.6 && <0.7,- midi >=0.2.1 && <0.3,- storable-record >=0.0.2 && <0.1,- storable-tuple >=0.0.2 && <0.1,- storablevector >=0.2.6 && <0.3,- numeric-prelude >=0.3 && <0.5,- non-negative >=0.1 && <0.2,- explicit-exception >=0.1.7 && <0.2,- event-list >=0.1 && <0.2,- shell-utility >=0.0 && <0.1,- pathtype >=0.8 && <0.9,- optparse-applicative >=0.11 && <0.16,- containers >=0.1 && <0.7,- transformers,- utility-ht,-- base >=4 && <5+ midi,+ storablevector,+ non-negative,+ event-list,+ shell-utility,+ pathtype,+ optparse-applicative,+ base Else Buildable: False@@ -428,18 +428,16 @@ GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax Default-Extensions: CPP- Hs-Source-Dirs: render, server+ Hs-Source-Dirs: render Main-Is: Synthesizer/LLVM/Server/Render.hs Other-Modules:- Synthesizer.LLVM.Server.CausalPacked.Arrange Synthesizer.LLVM.Server.Option- Synthesizer.LLVM.Server.OptionCommon- Synthesizer.LLVM.Server.Default Executable synthi-llvm-sample If flag(buildExamples) Build-Depends: gnuplot >=0.5 && <0.6,+ synthesizer-llvm-server, synthesizer-llvm, synthesizer-core, midi,@@ -447,7 +445,7 @@ storablevector, pathtype, utility-ht,- base >=4 && <5+ base Else Buildable: False Default-Language: Haskell98@@ -460,7 +458,7 @@ GHC-Options: -fcontext-stack=1000 Else GHC-Options: -freduction-depth=1000- Hs-Source-Dirs: ., server+ Hs-Source-Dirs: . Main-Is: src/Synthesizer/LLVM/Server/SampledSoundAnalysis.hs Executable synthi-llvm-speech@@ -474,7 +472,7 @@ numeric-prelude, storablevector, utility-ht,- base >=4 && <5+ base Else Buildable: False Default-Language: Haskell98@@ -498,13 +496,13 @@ llvm-tf, tfp, synthesizer-core,- storablevector >=0.2.6 && <0.3,- numeric-prelude >=0.3 && <0.5,+ storablevector,+ numeric-prelude, random, utility-ht, QuickCheck >=1 && <3,- base >=4 && <5+ base Default-Language: Haskell98 GHC-Options: -Wall If impl(ghc>=7.0)
testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs view
@@ -14,7 +14,8 @@ import Test.Synthesizer.LLVM.Generator (Test, checkWithParam, arg, pair, triple, withGenArgs, ) import Test.Synthesizer.LLVM.Utility- (CheckEquality, checkEquality, genRandomVectorParam, randomSignal, )+ (CheckEquality, CheckEquality2, checkEquality, checkEquality2,+ genRandomVectorParam, randomSignal, ) import Control.Applicative (pure, ) @@ -103,7 +104,7 @@ (RingBuffer.trackSkip (pure bufferSize) noise $* 1)) trackSkipHold ::- Test ((Int, Rnd.StdGen), Word32, Word32) (CheckEquality (Bool, Float))+ Test ((Int, Rnd.StdGen), Word32, Word32) (CheckEquality2 Bool Float) trackSkipHold = let bufferSize = 1000 in withGenArgs@@ -114,7 +115,7 @@ \(sk, k, seed) -> let skips = randomSkips sk noise = SigP.noise seed 1- in checkEquality limitFloat+ in checkEquality2 limitFloat limitFloat (fmap ((,) (LLVM.valueOf True)) $ (CausalP.map RingBuffer.index k $* (RingBuffer.trackSkip (pure bufferSize) noise $* skips)))
testsuite/Test/Synthesizer/LLVM/Utility.hs view
@@ -5,9 +5,11 @@ import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Plug.Output as POut import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.Zip as Zip import Control.Monad (liftM, liftM2, ) import Control.Applicative ((<$>), )@@ -25,6 +27,8 @@ import System.Random (Random, randomRs, StdGen, mkStdGen, ) +import Data.Tuple.HT (mapPair)+ import qualified Test.QuickCheck as QC import qualified Algebra.RealRing as RealRing@@ -51,9 +55,9 @@ SVL.cycle $ SVL.fromChunks [randomStorableVector range param] randomSignal ::- (Class.MakeValueTuple a, Class.ValueTuple a ~ tuple, Memory.C tuple,+ (Class.MakeValueTuple a, Class.ValueTuple a ~ al, Memory.C al, Storable a, Random a) =>- (a, a) -> Param.T p (Int, StdGen) -> SigP.T p (Class.ValueTuple a)+ (a, a) -> Param.T p (Int, StdGen) -> SigP.T p al randomSignal range p = SigP.fromStorableVectorLazy (randomStorableVectorLoop range <$> p) @@ -61,14 +65,22 @@ render :: (Storable a, Class.MakeValueTuple a, Class.ValueTuple a ~ al, Memory.C al) => (SVL.Vector a -> sig) ->- SigP.T p (Class.ValueTuple a) -> IO (ChunkSize -> p -> sig)+ SigP.T p al -> IO (ChunkSize -> p -> sig) render limit sig =- fmap- (\func chunkSize ->- limit . func chunkSize) $- SigP.runChunky sig+ fmap (\func chunkSize -> limit . func chunkSize) $ SigP.runChunky sig +render2 ::+ (Storable a, Class.MakeValueTuple a, Class.ValueTuple a ~ al, Memory.C al) =>+ (Storable b, Class.MakeValueTuple b, Class.ValueTuple b ~ bl, Memory.C bl) =>+ ((SVL.Vector a, SVL.Vector b) -> sig) ->+ SigP.T p (al, bl) -> IO (ChunkSize -> p -> sig)+render2 limit sig =+ fmap (\func chunkSize ->+ limit . mapPair (SVL.fromChunks, SVL.fromChunks) .+ unzip . map (\(Zip.Cons a b) -> (a,b)) . func chunkSize) $+ SigP.runChunkyPlugged sig POut.deflt + data CheckSimilarityState a = CheckSimilarityState a (SVL.Vector a) (SigS.T a) @@ -141,12 +153,14 @@ we use this interim data type. This allows us to inspect the signals that are compared. -}-data CheckEquality a =- CheckEquality (SVL.Vector a) (SVL.Vector a)+data CheckEqualityGen a = CheckEqualityGen a a -instance (Storable a, Eq a) => QC.Testable (CheckEquality a) where- property (CheckEquality x y) = QC.property (x==y)+type CheckEquality a = CheckEqualityGen (SVL.Vector a)+type CheckEquality2 a b = CheckEqualityGen (SVL.Vector a, SVL.Vector b) +instance (Eq a) => QC.Testable (CheckEqualityGen a) where+ property (CheckEqualityGen x y) = QC.property (x==y)+ checkEquality :: (Eq a, Storable a, Class.MakeValueTuple a, Class.ValueTuple a ~ av,@@ -157,6 +171,22 @@ checkEquality limit gen0 gen1 = liftM2 (\sig0 sig1 chunkSize p ->- CheckEquality (sig0 chunkSize p) (sig1 chunkSize p))+ CheckEqualityGen (sig0 chunkSize p) (sig1 chunkSize p)) (render limit gen0) (render limit gen1)++checkEquality2 ::+ (Eq a, Storable a,+ Class.MakeValueTuple a, Class.ValueTuple a ~ al, Memory.C al) =>+ (Eq b, Storable b,+ Class.MakeValueTuple b, Class.ValueTuple b ~ bl, Memory.C bl) =>+ (SVL.Vector a -> SVL.Vector a) ->+ (SVL.Vector b -> SVL.Vector b) ->+ SigP.T p (al,bl) -> SigP.T p (al,bl) ->+ IO (ChunkSize -> p -> CheckEquality2 a b)+checkEquality2 limitA limitB gen0 gen1 =+ liftM2+ (\sig0 sig1 chunkSize p ->+ CheckEqualityGen (sig0 chunkSize p) (sig1 chunkSize p))+ (render2 (mapPair (limitA, limitB)) gen0)+ (render2 (mapPair (limitA, limitB)) gen1)