synthesizer-llvm 1.0 → 1.1
raw patch · 11 files changed
+516/−448 lines, 11 filesdep ~llvm-dsl
Dependency ranges changed: llvm-dsl
Files
- example/Synthesizer/LLVM/Test.hs +5/−5
- src/Synthesizer/LLVM/Causal/FunctionalPlug.hs +6/−6
- src/Synthesizer/LLVM/Causal/Parameterized.hs +0/−67
- src/Synthesizer/LLVM/Causal/Parametric.hs +69/−0
- src/Synthesizer/LLVM/Causal/Process.hs +8/−8
- src/Synthesizer/LLVM/Causal/Render.hs +62/−37
- src/Synthesizer/LLVM/Generator/Render.hs +64/−291
- src/Synthesizer/LLVM/Private/Render.hs +267/−0
- src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs +26/−27
- src/Synthesizer/LLVM/Server/Common.hs +4/−3
- synthesizer-llvm.cabal +5/−4
example/Synthesizer/LLVM/Test.hs view
@@ -1066,7 +1066,7 @@ ^<< Causal.amplifyStereo 0.3 <<<- Causal.stereoFromMonoParameterized Causal.reverbExplicit params+ Causal.stereoFromMonoParametric Causal.reverbExplicit params <<^ (\x -> Stereo.cons x x)) playStereoVector =<<@@ -1196,7 +1196,7 @@ stereoOsciSawP volume = fmap Stereo.multiValue .- stereoFromMonoParameterizedSignal+ stereoFromMonoParametricSignal (\params -> Causal.amplify volume $* multiMixSignal@@ -1206,15 +1206,15 @@ (Expr.snd phaseFreq)) params) -stereoFromMonoParameterizedSignal ::+stereoFromMonoParametricSignal :: (Marshal.C x) => (D2 :*: LLVM.SizeOf (Marshal.Struct x) ~ arrSize, TypeNum.Natural arrSize) => (Exp x -> Sig.MV Float) -> Stereo.T (Exp x) -> Sig.T (Stereo.T (MultiValue.T Float))-stereoFromMonoParameterizedSignal f ps =+stereoFromMonoParametricSignal f ps = Causal.toSignal $- Causal.stereoFromMonoParameterized (Causal.fromSignal . f) ps+ Causal.stereoFromMonoParametric (Causal.fromSignal . f) ps <<^ (\() -> Stereo.cons () ())
src/Synthesizer/LLVM/Causal/FunctionalPlug.hs view
@@ -14,7 +14,7 @@ import qualified Synthesizer.LLVM.Plug.Input as PIn import qualified Synthesizer.LLVM.Plug.Output as POut -import qualified Synthesizer.LLVM.Causal.Parameterized as Parameterized+import qualified Synthesizer.LLVM.Causal.Parametric as Parametric import qualified Synthesizer.LLVM.Causal.Render as CausalRender import qualified Synthesizer.LLVM.Causal.Private as CausalPriv import qualified Synthesizer.LLVM.Causal.Process as Causal@@ -309,15 +309,15 @@ case fst ^<< process <<^ flip (,) Vault.empty of CausalPriv.Cons next start stop -> (\paramd ->- CausalRender.processIOParameterized pin paramd pout) $- Parameterized.Cons+ CausalRender.processIOParametric pin paramd pout) $+ Parametric.Cons (\p global local a state ->- MaybeCont.lift (Parameterized.loadParam ref p) >>+ MaybeCont.lift (Parametric.loadParam ref p) >> next global local a state) (\p ->- Parameterized.loadParam ref p >> start)+ Parametric.loadParam ref p >> start) (\p global ->- Parameterized.loadParam ref p >> stop global)+ Parametric.loadParam ref p >> stop global) run :: (Marshal.C pl) =>
− src/Synthesizer/LLVM/Causal/Parameterized.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Rank2Types #-}-module Synthesizer.LLVM.Causal.Parameterized where--import qualified Synthesizer.LLVM.Causal.Private as Causal--import LLVM.DSL.Expression (Exp(Exp))--import qualified LLVM.Extra.Multi.Value.Marshal as Marshal-import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.MaybeContinuation as MaybeCont-import qualified LLVM.Extra.Tuple as Tuple--import qualified LLVM.Core as LLVM--import Control.Monad.IO.Class (liftIO)--import Data.IORef (IORef, newIORef, readIORef, writeIORef)---data T p a b =- forall global local state.- (Memory.C global, LLVM.IsSized local, Memory.C state) =>- Cons (forall r c.- (Tuple.Phi c) =>- p -> global -> LLVM.Value (LLVM.Ptr local) ->- a -> state -> MaybeCont.T r c (b, state))- (forall r. p -> LLVM.CodeGenFunction r (global, state))- (forall r. p -> global -> LLVM.CodeGenFunction r ())---fromProcess :: String -> (Exp p -> Causal.T a b) -> IO (T (MultiValue.T p) a b)-fromProcess name f = do- ref <- newIORef $ error $ name ++ ": uninitialized parameter reference"- return $- case f (Exp (liftIO (readIORef ref))) of- Causal.Cons next start stop ->- Cons- (\p global local a state ->- liftIO (writeIORef ref p) >> next global local a state)- (\p -> liftIO (writeIORef ref p) >> start)- (\p global -> liftIO (writeIORef ref p) >> stop global)---fromProcessPtr ::- (Marshal.C p) =>- String -> (Exp p -> Causal.T a b) ->- IO (T (LLVM.Value (LLVM.Ptr (Marshal.Struct p))) a b)-fromProcessPtr name f = do- ref <- newIORef $ error $ name ++ ": uninitialized parameter reference"- return $- case f (Exp (liftIO (readIORef ref))) of- Causal.Cons next start stop ->- Cons- (\p global local a state ->- MaybeCont.lift (loadParam ref p) >> next global local a state)- (\p -> loadParam ref p >> start)- (\p global -> loadParam ref p >> stop global)--loadParam ::- (Marshal.C param) =>- IORef (MultiValue.T param) ->- LLVM.Value (LLVM.Ptr (Marshal.Struct param)) ->- LLVM.CodeGenFunction r ()-loadParam ref ptr = liftIO . writeIORef ref =<< Memory.load ptr
+ src/Synthesizer/LLVM/Causal/Parametric.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Synthesizer.LLVM.Causal.Parametric where++import qualified Synthesizer.LLVM.Causal.Private as Causal++import LLVM.DSL.Expression (Exp(Exp))++import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM++import Control.Monad.IO.Class (liftIO)++import Data.IORef (IORef, newIORef, readIORef, writeIORef)+++data T p a b =+ forall global local state.+ (Memory.C global, LLVM.IsSized local, Memory.C state) =>+ Cons (forall r c.+ (Tuple.Phi c) =>+ p -> global -> LLVM.Value (LLVM.Ptr local) ->+ a -> state -> MaybeCont.T r c (b, state))+ (forall r. p -> LLVM.CodeGenFunction r (global, state))+ (forall r. p -> global -> LLVM.CodeGenFunction r ())+++fromProcess :: String -> (Exp p -> Causal.T a b) -> IO (T (MultiValue.T p) a b)+fromProcess name f = do+ ref <- newIORef $ error $ name ++ ": uninitialized parameter reference"+ return $+ case f (Exp (liftIO (readIORef ref))) of+ Causal.Cons next start stop ->+ Cons+ (\p global local a state ->+ liftIO (writeIORef ref p) >> next global local a state)+ (\p -> liftIO (writeIORef ref p) >> start)+ (\p global -> liftIO (writeIORef ref p) >> stop global)+++type MarshalPtr a = LLVM.Ptr (Marshal.Struct a)++fromProcessPtr ::+ (Marshal.C p) =>+ String -> (Exp p -> Causal.T a b) ->+ IO (T (LLVM.Value (MarshalPtr p)) a b)+fromProcessPtr name f = do+ ref <- newIORef $ error $ name ++ ": uninitialized parameter reference"+ return $+ case f (Exp (liftIO (readIORef ref))) of+ Causal.Cons next start stop ->+ Cons+ (\p global local a state ->+ MaybeCont.lift (loadParam ref p) >> next global local a state)+ (\p -> loadParam ref p >> start)+ (\p global -> loadParam ref p >> stop global)++loadParam ::+ (Marshal.C param) =>+ IORef (MultiValue.T param) ->+ LLVM.Value (MarshalPtr param) ->+ LLVM.CodeGenFunction r ()+loadParam ref ptr = liftIO . writeIORef ref =<< Memory.load ptr
src/Synthesizer/LLVM/Causal/Process.hs view
@@ -46,7 +46,7 @@ replicateControlledParam, stereoFromMono, stereoFromMonoControlled,- stereoFromMonoParameterized,+ stereoFromMonoParametric, comb, combStereo, reverbExplicit,@@ -57,7 +57,7 @@ pipeline, ) where -import qualified Synthesizer.LLVM.Causal.Parameterized as Parameterized+import qualified Synthesizer.LLVM.Causal.Parametric as Parametric import qualified Synthesizer.LLVM.Causal.Private as Causal import qualified Synthesizer.LLVM.Generator.Private as SigPriv import qualified Synthesizer.LLVM.Generator.Signal as Sig@@ -275,10 +275,10 @@ replicateControlledParam f ps = Unsafe.performIO $ do let n :: Word n = TypeNum.integralFromProxy $ arraySize ps- paramd <- Parameterized.fromProcessPtr "Causal.replicateControlledParam" f+ paramd <- Parametric.fromProcessPtr "Causal.replicateControlledParam" f return $ case paramd of- Parameterized.Cons next start stop ->+ Parametric.Cons next start stop -> Causal.Cons (\(bPtr,globalPtr) localPtr (c,a0) statePtr -> do a1 <-@@ -370,14 +370,14 @@ MultiValue.insertArrayValue TypeNum.d0 (Stereo.left a) =<< MultiValue.insertArrayValue TypeNum.d1 (Stereo.right a) MultiValue.undef -stereoFromMonoParameterized ::+stereoFromMonoParametric :: (Marshal.C x, Tuple.Phi a, Tuple.Undefined a, Tuple.Phi b, Tuple.Undefined b) => ((TypeNum.D2 TypeNum.:*: LLVM.SizeOf (Marshal.Struct x)) ~ xSize, TypeNum.Natural xSize) => (Exp x -> Causal.T a b) -> Stereo.T (Exp x) -> Causal.T (Stereo.T a) (Stereo.T b)-stereoFromMonoParameterized f sx =+stereoFromMonoParametric f sx = snd ^<< replicateControlledParam@@ -743,10 +743,10 @@ Causal.T (Maybe.T (MultiValue.T a)) (Maybe.T b) trigger f = Unsafe.performIO $ do paramd <-- Parameterized.fromProcess "Causal.trigger" (CausalClass.fromSignal . f)+ Parametric.fromProcess "Causal.trigger" (CausalClass.fromSignal . f) return $ case paramd of- Parameterized.Cons next start stop -> Causal.Cons+ Parametric.Cons next start stop -> Causal.Cons (\globalPtr local ma ms0 -> MaybeCont.lift $ do ms1 <- Maybe.run ma
src/Synthesizer/LLVM/Causal/Render.hs view
@@ -3,14 +3,29 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-}-module Synthesizer.LLVM.Causal.Render where+module Synthesizer.LLVM.Causal.Render (+ -- * type driven+ RunArg, DSLArg,+ run,+ runPlugged,+ processIO,+ Render.Buffer, Render.buffer, -import qualified Synthesizer.LLVM.Causal.Parameterized as Parameterized+ -- * explicit argument converters+ runPluggedExplicit,+ build, -- ToDo: better name+ Plugs,++ -- * internally used in FunctionalPlug+ processIOParametric,+ ) where++import qualified Synthesizer.LLVM.Private.Render as Render+import qualified Synthesizer.LLVM.Causal.Parametric as Parametric import Synthesizer.LLVM.Causal.Private (T(Cons))-import Synthesizer.LLVM.Generator.Render- (Triple, tripleStruct,- derefStartPtr, derefStopPtr,- RunArg, DSLArg, BuildArg(BuildArg), buildArg)+import Synthesizer.LLVM.Private.Render+ (RunArg (DSLArg, buildArg),+ Triple, tripleStruct, derefStartPtr, derefStopPtr) import qualified Synthesizer.LLVM.Plug.Input as PIn import qualified Synthesizer.LLVM.Plug.Output as POut@@ -18,8 +33,10 @@ import qualified Synthesizer.CausalIO.Process as PIO import qualified Synthesizer.Generic.Cut as Cut +import qualified LLVM.DSL.Render.Run as Run+import qualified LLVM.DSL.Render.Argument as Arg import qualified LLVM.DSL.Execution as Exec-import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Render.Run ((*->)) import LLVM.DSL.Expression (Exp(Exp)) import qualified LLVM.Extra.Multi.Value.Storable as Storable@@ -37,6 +54,7 @@ import qualified Data.StorableVector.Base as SVB import qualified Data.StorableVector as SV +import qualified Control.Monad.Trans.Reader as MR import Control.Monad (when, join) import Control.Applicative (liftA3) @@ -89,19 +107,19 @@ final return $ fromIntegral n -run_ ::+_run :: (Marshal.C p, Storable.C a, MultiValue.T a ~ al, Storable.C b, MultiValue.T b ~ bl) => (Exp p -> T al bl) -> IO (p -> SV.Vector a -> IO (SV.Vector b))-run_ = fmap ($ return ()) . runAux+_run = fmap ($ return ()) . runAux foreign import ccall safe "dynamic" derefChunkPtr :: Exec.Importer (LLVM.Ptr globalState -> Word -> Ptr a -> Ptr b -> IO Word) -compileChunky ::+_compileChunky :: (LLVM.IsSized paramStruct, LLVM.Value (LLVM.Ptr paramStruct) ~ pPtr, Memory.C state, Memory.Struct state ~ stateStruct, Memory.C global, Memory.Struct global ~ globalStruct,@@ -118,7 +136,7 @@ IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr triple), Exec.Finalizer triple, LLVM.Ptr triple -> Word -> Ptr a -> Ptr b -> IO Word)-compileChunky next start stop =+_compileChunky next start stop = Exec.compile "process-chunky" $ liftA3 (,,) (Exec.createFunction derefStartPtr "startprocess" $@@ -267,16 +285,16 @@ In a second step we could convert this to a processor of lazy lists, and thus to a processor of chunky storable vectors. -}-processIOParameterized ::+processIOParametric :: (Marshal.C p, Cut.Read a, x ~ LLVM.Value (LLVM.Ptr (Marshal.Struct p))) =>- PIn.T a b -> Parameterized.T x b c -> POut.T c d ->- IO (IO (p, IO ()) -> PIO.T a d)-processIOParameterized+ PIn.T a b -> Parametric.T x b c -> POut.T c d ->+ IO (Arg.Creator p -> PIO.T a d)+processIOParametric (PIn.Cons nextIn startIn createIn deleteIn) paramd (POut.Cons nextOut startOut createOut deleteOut) = do case paramd of- Parameterized.Cons next start stop -> do+ Parametric.Cons next start stop -> do (startFunc, stopFunc, fill) <- compilePlugged nextIn startIn@@ -308,10 +326,10 @@ processIOCore :: (Marshal.C p, Cut.Read a) => PIn.T a b -> (Exp p -> T b c) -> POut.T c d ->- IO (IO (p, IO ()) -> PIO.T a d)+ IO (Arg.Creator p -> PIO.T a d) processIOCore pin proc pout = do- paramd <- Parameterized.fromProcessPtr "Causal.process" proc- processIOParameterized pin paramd pout+ paramd <- Parametric.fromProcessPtr "Causal.process" proc+ processIOParametric pin paramd pout processIO :: (Marshal.C p, Cut.Read a, PIn.Default a, POut.Default d) =>@@ -322,43 +340,50 @@ processIOCore PIn.deflt proc POut.deflt +type Plugs f a b = MR.ReaderT (PIn.T (In f) a, POut.T b (Out f)) IO+ class Run f where type DSL f a b type In f type Out f- build ::- (Marshal.C p) =>- PIn.T (In f) a -> (Exp p -> DSL f a b) -> POut.T b (Out f) ->- IO (IO (p, IO ()) -> f)+ build :: (Marshal.C p) => Run.T (Plugs f a b) p (DSL f a b) f instance (Cut.Read a) => Run (PIO.T a b) where type DSL (PIO.T a b) al bl = T al bl type In (PIO.T a b) = a type Out (PIO.T a b) = b- build = processIOCore+ build =+ Run.Cons $ \proc ->+ MR.ReaderT $ \(pin,pout) -> processIOCore pin proc pout instance (RunArg a, Run f) => Run (a -> f) where type DSL (a -> f) al bl = DSLArg a -> DSL f al bl type In (a -> f) = In f type Out (a -> f) = Out f- build pin sig pout =- case buildArg of- BuildArg pass createA -> do- f <- build pin (Expr.uncurry $ \p -> sig p . pass) pout- return $ \createP av ->- f (do (p,finalP) <- createP- (pa,finalA) <- createA av- return ((p,pa), finalA >> finalP))+ build = buildArg *-> build -runPlugged :: (Run f) => PIn.T (In f) a -> DSL f a b -> POut.T b (Out f) -> IO f-runPlugged pin sig pout = do- act <- build pin (const sig) pout- return $ act (return ((), return ()))+runPluggedExplicit ::+ Run.T (Plugs f a b) () (DSL f a b) f ->+ PIn.T (In f) a -> DSL f a b -> POut.T b (Out f) -> IO f+runPluggedExplicit builder pin proc pout =+ MR.runReaderT (Run.run builder proc) (pin,pout) +runPlugged ::+ (Run f) => PIn.T (In f) a -> DSL f a b -> POut.T b (Out f) -> IO f+runPlugged = runPluggedExplicit build+ run :: (Run f) => (In f ~ a, PIn.Default a, PIn.Element a ~ al) => (Out f ~ b, POut.Default b, POut.Element b ~ bl) => DSL f al bl -> IO f-run sig = runPlugged PIn.deflt sig POut.deflt+run proc = runPlugged PIn.deflt proc POut.deflt++_exampleExplicit ::+ (Exp Float -> Exp Word -> T (MultiValue.T Float) (MultiValue.T Word)) ->+ IO (Float -> Word -> PIO.T (SV.Vector Float) (SV.Vector Word))+_exampleExplicit proc =+ runPluggedExplicit+ (Arg.primitive *-> Arg.primitive *-> build)+ PIn.storableVector proc POut.storableVector
src/Synthesizer/LLVM/Generator/Render.hs view
@@ -1,29 +1,42 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-}-module Synthesizer.LLVM.Generator.Render where+module Synthesizer.LLVM.Generator.Render (+ -- * type driven+ RunArg, DSLArg,+ run,+ runChunky,+ runChunkyOnVector,+ Render.Buffer, Render.buffer, -import qualified Synthesizer.LLVM.Causal.Parameterized as Parameterized+ -- * explicit argument converters+ runExplicit,+ build, -- ToDo: better name+ WithShape,++ -- * utilities+ Render.TimeInteger(Render.subdivideLong), -- ToDo: Is Render the right module to define this?+ ) where++import qualified Synthesizer.LLVM.Private.Render as Render+import qualified Synthesizer.LLVM.Causal.Parametric as Parametric import qualified Synthesizer.LLVM.Generator.Source as Source-import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt-import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt-import qualified Synthesizer.LLVM.EventIterator as EventIt+import Synthesizer.LLVM.Private.Render+ (RunArg (DSLArg, buildArg),+ Triple, tripleStruct, derefStartPtr, derefStopPtr) import Synthesizer.LLVM.Generator.Private (T(Cons)) -import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Storable.Vector as SVU import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr-import qualified Synthesizer.LLVM.ConstantPiece as Const -import qualified Synthesizer.PiecewiseConstant.Signal as PC import qualified Synthesizer.Causal.Class as CausalClass +import qualified LLVM.DSL.Render.Run as Run+import qualified LLVM.DSL.Render.Argument as Arg import qualified LLVM.DSL.Execution as Exec-import qualified LLVM.DSL.Expression as Expr+import LLVM.DSL.Render.Run ((*->)) import LLVM.DSL.Expression (Exp(Exp)) import qualified LLVM.Extra.Multi.Value.Storable as Storable@@ -32,8 +45,6 @@ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.MaybeContinuation as MaybeCont import qualified LLVM.Extra.Maybe as Maybe-import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Core as LLVM@@ -44,19 +55,15 @@ import qualified Data.StorableVector.Base as SVB import qualified Data.StorableVector as SV -import qualified Data.EventList.Relative.BodyTime as EventList-import qualified Numeric.NonNegative.Wrapper as NonNeg-import qualified Numeric.NonNegative.Chunky as NonNegChunky- import Control.Monad (join) import Control.Applicative (liftA3) import Foreign.ForeignPtr (touchForeignPtr) import Foreign.Ptr (Ptr) -import Data.Foldable (traverse_)-import Data.Tuple.Strict (mapPair, mapTriple)-import Data.Word (Word, Word8, Word32)+import Data.Functor.Compose (Compose (Compose, getCompose))+import Data.Int (Int)+import Data.Word (Word) import qualified System.Unsafe as Unsafe @@ -96,126 +103,15 @@ final return $ fromIntegral n -run_ ::+_run :: (Marshal.C p, Storable.C a, MultiValue.T a ~ value) => (Exp p -> T value) -> IO (Int -> p -> IO (SV.Vector a))-run_ = fmap ($ return ()) . runAux---foreign import ccall safe "dynamic" derefStartPtr ::- Exec.Importer (LLVM.Ptr param -> IO (LLVM.Ptr globalState))--foreign import ccall safe "dynamic" derefStopPtr ::- Exec.Importer (LLVM.Ptr globalState -> IO ())+_run = fmap ($ return ()) . runAux foreign import ccall safe "dynamic" derefChunkPtr :: Exec.Importer (LLVM.Ptr globalState -> Word -> Ptr a -> IO Word) -type MemoryPtr a = LLVM.Ptr (Memory.Struct a)--type WithGlobalState param = LLVM.Struct (param, ())--type Pair a b = LLVM.Struct (a,(b,()))-type Triple a b c = LLVM.Struct (a,(b,(c,())))--tripleStruct ::- (LLVM.IsSized a, LLVM.IsSized b, LLVM.IsSized c) =>- LLVM.Value a -> LLVM.Value b -> LLVM.Value c ->- LLVM.CodeGenFunction r (LLVM.Value (Triple a b c))-tripleStruct a b c = do- s0 <- LLVM.insertvalue Tuple.undef a TypeNum.d0- s1 <- LLVM.insertvalue s0 b TypeNum.d1- LLVM.insertvalue s1 c TypeNum.d2--{- |-This is a pretty ugly hack, but its seems to be the least ugly one.-We need to solve the following problem:-We have a function of type @Exp param -> T value@.-This means that all methods in @T value@ depend on @Exp param@.-We need to choose one piece of LLVM code in @Exp param@-that generates appropriate code for all methods in @T value@.-If we access a function parameter via @Memory.load paramPtr@-this means that all methods must end up in the same LLVM function-in order to access this parameter.-Thus I have to put all functionality in one LLVM function-and then the three functions in 'compileChunky'-jump into the handler function with a 'Word8' code-specifying the actual sub-routine.-We need to squeeze all possible inputs and outputs-through one function interface.--However, since the handler is marked as internal-the optimizer inlines it in the three functions from 'compileChunky'-and eliminates dead code.-This way, we end up with the code that we would have written otherwise.--The alternative would be to construct @T value@ multiple times.-Due to existential quantification we cannot prove-that the pointer types of different methods match,-so we need to cast pointers.-However, with the current approach we also have to do that.--}-compileHandler ::- (Marshal.C param, Marshal.Struct param ~ paramStruct,- Storable.C a, MultiValue.T a ~ value) =>- (Exp param -> T value) ->- LLVM.CodeGenModule- (LLVM.Function- (Word8 -> LLVM.Ptr paramStruct -> Word -> Ptr a ->- IO (Pair (LLVM.Ptr (WithGlobalState paramStruct)) Word)))-compileHandler sig =- LLVM.createNamedFunction LLVM.InternalLinkage "handlesignal" $- \phase paramPtr loopLen bufferPtr ->- case sig $ Exp (Memory.load paramPtr) of- Cons next start stop -> do- paramGlobalStatePtr <- LLVM.bitcast paramPtr-- let create = do- newParamGlobalStatePtr <- LLVM.malloc- (global,state) <- start- flip LLVM.store newParamGlobalStatePtr =<<- join- (liftA3 tripleStruct- (LLVM.load paramPtr)- (Memory.compose global)- (Memory.compose state))- newOpaqueParamGlobalStatePtr <-- LLVM.bitcast- (newParamGlobalStatePtr `asTypeOf` paramGlobalStatePtr)- LLVM.insertvalue Tuple.undef- newOpaqueParamGlobalStatePtr TypeNum.d0-- let delete = do- globalPtr <-- LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())- stop =<< Memory.load globalPtr- LLVM.free paramGlobalStatePtr- return Tuple.undef-- let fill = do- globalPtr <-- LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())- statePtr <-- LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d2, ())- global <- Memory.load globalPtr- sInit <- Memory.load statePtr- local <- LLVM.alloca- (pos,sExit) <-- Storable.arrayLoopMaybeCont loopLen bufferPtr sInit $- \ ptr s0 -> do- (y,s1) <- next global local s0- MaybeCont.lift $ Storable.store y ptr- return s1- Memory.store (Maybe.fromJust sExit) statePtr- LLVM.insertvalue Tuple.undef pos TypeNum.d1-- doCreate <- A.cmp LLVM.CmpEQ (LLVM.valueOf 0) phase- doDelete <- A.cmp LLVM.CmpEQ (LLVM.valueOf 1) phase- C.ret =<<- (C.ifThenElse doCreate create $- C.ifThenElse doDelete delete fill)- compileChunky :: (LLVM.IsSized paramStruct, LLVM.Value (LLVM.Ptr paramStruct) ~ pPtr, Memory.C state, Memory.Struct state ~ stateStruct,@@ -279,9 +175,9 @@ (Exp p -> T value) -> IO (IO () -> SVL.ChunkSize -> p -> IO (SVL.Vector a)) runChunkyAux sig = do paramd <-- Parameterized.fromProcessPtr "Signal.run" (CausalClass.fromSignal . sig)+ Parametric.fromProcessPtr "Signal.run" (CausalClass.fromSignal . sig) case paramd of- Parameterized.Cons next start stop -> do+ Parametric.Cons next start stop -> do (startFunc,stopFunc,fill) <- compileChunky next start stop return $ \final (SVL.ChunkSize size) p -> do statePtr <- ForeignPtr.newParamMV stopFunc startFunc p@@ -319,25 +215,30 @@ f (touchForeignPtr fp) chunkSize (Source.consStorableVector ptr l) ++type WithShape shape = Compose IO ((->) shape)+ class Run f where type DSL f type Shape f- build ::- (Marshal.C p) =>- (Exp p -> DSL f) -> IO (IO (p, IO ()) -> Shape f -> f)+ build :: (Marshal.C p) => Run.T (WithShape (Shape f)) p (DSL f) f instance (Storable.C a) => Run (SVL.Vector a) where type DSL (SVL.Vector a) = T (MultiValue.T a) type Shape (SVL.Vector a) = SVL.ChunkSize build =- fmap (\f create shape -> Unsafe.performIO $ buildIOGen f create shape) .+ Run.Cons $+ Compose .+ fmap (\f shape create -> Unsafe.performIO $ buildIOGen f shape create) . runChunkyAux instance (Storable.C a) => Run (SV.Vector a) where type DSL (SV.Vector a) = T (MultiValue.T a) type Shape (SV.Vector a) = Int build =- fmap (\f create shape -> Unsafe.performIO $ buildIOGen f create shape) .+ Run.Cons $+ Compose .+ fmap (\f shape create -> Unsafe.performIO $ buildIOGen f shape create) . runAux instance (RunIO a) => Run (IO a) where@@ -348,178 +249,50 @@ instance (RunArg a, Run f) => Run (a -> f) where type DSL (a -> f) = DSLArg a -> DSL f type Shape (a -> f) = Shape f- build sig =- case buildArg of- BuildArg pass createA -> do- f <- build (Expr.uncurry $ \p -> sig p . pass)- return $ \createP shape av ->- f (do (p,finalP) <- createP- (pa,finalA) <- createA av- return ((p,pa), finalA >> finalP))- shape+ build = buildArg *-> build class RunIO a where type DSL_IO a type ShapeIO a buildIO ::- (Marshal.C p) =>- (Exp p -> T (DSL_IO a)) -> IO (IO (p, IO ()) -> ShapeIO a -> IO a)+ (Marshal.C p) => Run.T (WithShape (ShapeIO a)) p (T (DSL_IO a)) (IO a) instance (Storable.C a) => RunIO (SVL.Vector a) where type DSL_IO (SVL.Vector a) = MultiValue.T a type ShapeIO (SVL.Vector a) = SVL.ChunkSize- buildIO = fmap buildIOGen . runChunkyAux+ buildIO = Run.Cons $ Compose . fmap buildIOGen . runChunkyAux instance (Storable.C a) => RunIO (SV.Vector a) where type DSL_IO (SV.Vector a) = MultiValue.T a type ShapeIO (SV.Vector a) = Int- buildIO = fmap buildIOGen . runAux+ buildIO = Run.Cons $ Compose . fmap buildIOGen . runAux buildIOGen ::- (Monad m) => (final -> shape -> p -> m a) -> m (p, final) -> shape -> m a-buildIOGen f create shape = do (p,final) <- create; f final shape p+ (Monad m) => (final -> shape -> p -> m a) -> shape -> m (p, final) -> m a+buildIOGen f shape create = do (p,final) <- create; f final shape p -data BuildArg a =- forall al. Marshal.C al =>- BuildArg (Exp al -> DSLArg a) (a -> IO (al, IO ())) -class RunArg a where- type DSLArg a- buildArg :: BuildArg a--instance RunArg () where- type DSLArg () = ()- buildArg = BuildArg (\ _unit -> ()) (\() -> return ((), return ()))--instance (RunArg a, RunArg b) => RunArg (a,b) where- type DSLArg (a,b) = (DSLArg a, DSLArg b)- buildArg =- case (buildArg,buildArg) of- (BuildArg passA createA, BuildArg passB createB) ->- BuildArg- (mapPair (passA,passB) . Expr.unzip)- (\(a,b) -> do- (pa,finalA) <- createA a- (pb,finalB) <- createB b- return ((pa,pb), finalB>>finalA))--instance (RunArg a, RunArg b, RunArg c) => RunArg (a,b,c) where- type DSLArg (a,b,c) = (DSLArg a, DSLArg b, DSLArg c)- buildArg =- case (buildArg,buildArg,buildArg) of- (BuildArg passA createA, BuildArg passB createB,- BuildArg passC createC) ->- BuildArg- (mapTriple (passA,passB,passC) . Expr.unzip3)- (\(a,b,c) -> do- (pa,finalA) <- createA a- (pb,finalB) <- createB b- (pc,finalC) <- createC c- return ((pa,pb,pc), finalC>>finalB>>finalA))--primitiveArg :: (Marshal.C a, DSLArg a ~ Exp a) => BuildArg a-primitiveArg = BuildArg id (\a -> return (a, return ()))--instance RunArg Float where- type DSLArg Float = Exp Float- buildArg = primitiveArg--instance RunArg Int where- type DSLArg Int = Exp Int- buildArg = primitiveArg--instance RunArg Word where- type DSLArg Word = Exp Word- buildArg = primitiveArg--instance RunArg Word32 where- type DSLArg Word32 = Exp Word32- buildArg = primitiveArg--instance (RunArg a) => RunArg (Stereo.T a) where- type DSLArg (Stereo.T a) = Stereo.T (DSLArg a)- buildArg =- case buildArg of- BuildArg pass create ->- BuildArg- (fmap pass . Stereo.unExpression)- (\s -> do- pf <- traverse create s- return (fst<$>pf, traverse_ snd pf))--instance- (TypeNum.Natural n, Marshal.C a, LLVM.IsSized (Marshal.Struct a),- TypeNum.Natural (n TypeNum.:*: LLVM.SizeOf (Marshal.Struct a))) =>- RunArg (MultiValue.Array n a) where- type DSLArg (MultiValue.Array n a) = Exp (MultiValue.Array n a)- buildArg = primitiveArg--instance (Storable.C a) => RunArg (SV.Vector a) where- type DSLArg (SV.Vector a) = T (MultiValue.T a)- buildArg =- BuildArg- Source.storableVector- (\av -> do- let (fp,ptr,l) = SVU.unsafeToPointers av- return (Source.consStorableVector ptr l, touchForeignPtr fp))--newtype Buffer a = Buffer (SV.Vector a)--buffer :: SV.Vector a -> Buffer a-buffer = Buffer--instance (Storable.C a) => RunArg (Buffer a) where- type DSLArg (Buffer a) = Exp (Source.StorableVector a)- buildArg =- BuildArg id- (\(Buffer av) -> do- let (fp,ptr,l) = SVU.unsafeToPointers av- return (Source.consStorableVector ptr l, touchForeignPtr fp))--newDisposeArg ::- (Marshal.C handle) =>- (a -> IO handle) -> (handle -> IO ()) ->- (Exp handle -> DSLArg a) -> BuildArg a-newDisposeArg new dispose fetch =- BuildArg fetch- (\x -> do- it <- new x- return (it, dispose it))--instance (Storable.C a) => RunArg (SVL.Vector a) where- type DSLArg (SVL.Vector a) = T (MultiValue.T a)- buildArg =- newDisposeArg ChunkIt.new ChunkIt.dispose Source.storableVectorLazy--class TimeInteger int where- subdivideLong :: EventList.T (NonNeg.T int) a -> EventList.T NonNeg.Int a--instance TimeInteger Int where- subdivideLong = id--instance TimeInteger Integer where- subdivideLong = PC.subdivideLongStrict--instance- (time ~ NonNeg.T int, TimeInteger int, Marshal.C a) =>- RunArg (EventList.T time a) where- type DSLArg (EventList.T time a) = T (Const.T (MultiValue.T a))- buildArg =- newDisposeArg- (EventIt.new . subdivideLong) EventIt.dispose Source.eventList--instance (a ~ SVL.ChunkSize) => RunArg (NonNegChunky.T a) where- type DSLArg (NonNegChunky.T a) = T (Const.T ())- buildArg =- newDisposeArg SizeIt.new SizeIt.dispose Source.lazySize- {- do f <- run (\n -> takeWhile (<*n) (iterate (1+) 0) <> takeWhile (<*n) (iterate (2+) 0)); f SVL.defaultChunkSize (12::Float) :: IO (SVL.Vector Float) do f <- Sig.run (\n -> Sig.takeWhile (Expr.<*n) (Sig.iterate (1+) 0) <> Sig.takeWhile (Expr.<*n) (Sig.iterate (2+) 0)); f SVL.defaultChunkSize (12::Float) :: IO (SVL.Vector Float) -} run :: (Run f) => DSL f -> IO (Shape f -> f)-run sig = do- act <- build (const sig)- return $ act (return ((), return ()))+run = runExplicit build++{-+ToDo:+Export it, but we also need to export 'build' then.+To this end we should define a nice data type for 'build'.+-}+runExplicit ::+ Run.T (WithShape (Shape f)) () fdsl f ->+ fdsl -> IO (Shape f -> f)+runExplicit builder sig =+ getCompose $ Run.run builder sig++_exampleExplicit ::+ (Exp Float -> Exp Word -> T (MultiValue.T Float)) ->+ IO (Int -> Float -> Word -> SV.Vector Float)+_exampleExplicit = runExplicit (Arg.primitive *-> Arg.primitive *-> build)
+ src/Synthesizer/LLVM/Private/Render.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.LLVM.Private.Render where++import qualified Synthesizer.LLVM.Generator.Source as Source+import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt+import qualified Synthesizer.LLVM.Storable.LazySizeIterator as SizeIt+import qualified Synthesizer.LLVM.EventIterator as EventIt+import Synthesizer.LLVM.Generator.Private (T(Cons))++import qualified Synthesizer.LLVM.Frame.Stereo as Stereo+import qualified Synthesizer.LLVM.Storable.Vector as SVU+import qualified Synthesizer.LLVM.ConstantPiece as Const++import qualified Synthesizer.PiecewiseConstant.Signal as PC++import qualified LLVM.DSL.Render.Argument as Arg+import qualified LLVM.DSL.Execution as Exec+import LLVM.DSL.Expression (Exp(Exp))++import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV++import qualified Data.EventList.Relative.BodyTime as EventList+import qualified Numeric.NonNegative.Wrapper as NonNeg+import qualified Numeric.NonNegative.Chunky as NonNegChunky++import Control.Monad (join)+import Control.Applicative (liftA3)++import Foreign.ForeignPtr (touchForeignPtr)+import Foreign.Ptr (Ptr)++import Data.Foldable (traverse_)+import Data.Int (Int)+import Data.Word (Word, Word8, Word32)++++foreign import ccall safe "dynamic" derefStartPtr ::+ Exec.Importer (LLVM.Ptr param -> IO (LLVM.Ptr globalState))++foreign import ccall safe "dynamic" derefStopPtr ::+ Exec.Importer (LLVM.Ptr globalState -> IO ())++++type Pair a b = LLVM.Struct (a,(b,()))+type Triple a b c = LLVM.Struct (a,(b,(c,())))++tripleStruct ::+ (LLVM.IsSized a, LLVM.IsSized b, LLVM.IsSized c) =>+ LLVM.Value a -> LLVM.Value b -> LLVM.Value c ->+ LLVM.CodeGenFunction r (LLVM.Value (Triple a b c))+tripleStruct a b c = do+ s0 <- LLVM.insertvalue Tuple.undef a TypeNum.d0+ s1 <- LLVM.insertvalue s0 b TypeNum.d1+ LLVM.insertvalue s1 c TypeNum.d2+++type WithGlobalState param = LLVM.Struct (param, ())++{- |+This is a pretty ugly hack, but its seems to be the least ugly one.+We need to solve the following problem:+We have a function of type @Exp param -> T value@.+This means that all methods in @T value@ depend on @Exp param@.+We need to choose one piece of LLVM code in @Exp param@+that generates appropriate code for all methods in @T value@.+If we access a function parameter via @Memory.load paramPtr@+this means that all methods must end up in the same LLVM function+in order to access this parameter.+Thus I have to put all functionality in one LLVM function+and then the three functions in 'compileChunky'+jump into the handler function with a 'Word8' code+specifying the actual sub-routine.+We need to squeeze all possible inputs and outputs+through one function interface.++However, since the handler is marked as internal+the optimizer inlines it in the three functions from 'compileChunky'+and eliminates dead code.+This way, we end up with the code that we would have written otherwise.++The alternative would be to construct @T value@ multiple times.+Due to existential quantification we cannot prove+that the pointer types of different methods match,+so we need to cast pointers.+However, with the current approach we also have to do that.+-}+compileHandler ::+ (Marshal.C param, Marshal.Struct param ~ paramStruct,+ Storable.C a, MultiValue.T a ~ value) =>+ (Exp param -> T value) ->+ LLVM.CodeGenModule+ (LLVM.Function+ (Word8 -> LLVM.Ptr paramStruct -> Word -> Ptr a ->+ IO (Pair (LLVM.Ptr (WithGlobalState paramStruct)) Word)))+compileHandler sig =+ LLVM.createNamedFunction LLVM.InternalLinkage "handlesignal" $+ \phase paramPtr loopLen bufferPtr ->+ case sig $ Exp (Memory.load paramPtr) of+ Cons next start stop -> do+ paramGlobalStatePtr <- LLVM.bitcast paramPtr++ let create = do+ newParamGlobalStatePtr <- LLVM.malloc+ (global,state) <- start+ flip LLVM.store newParamGlobalStatePtr =<<+ join+ (liftA3 tripleStruct+ (LLVM.load paramPtr)+ (Memory.compose global)+ (Memory.compose state))+ newOpaqueParamGlobalStatePtr <-+ LLVM.bitcast+ (newParamGlobalStatePtr `asTypeOf` paramGlobalStatePtr)+ LLVM.insertvalue Tuple.undef+ newOpaqueParamGlobalStatePtr TypeNum.d0++ let delete = do+ globalPtr <-+ LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())+ stop =<< Memory.load globalPtr+ LLVM.free paramGlobalStatePtr+ return Tuple.undef++ let fill = do+ globalPtr <-+ LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d1, ())+ statePtr <-+ LLVM.getElementPtr0 paramGlobalStatePtr (TypeNum.d2, ())+ global <- Memory.load globalPtr+ sInit <- Memory.load statePtr+ local <- LLVM.alloca+ (pos,sExit) <-+ Storable.arrayLoopMaybeCont loopLen bufferPtr sInit $+ \ ptr s0 -> do+ (y,s1) <- next global local s0+ MaybeCont.lift $ Storable.store y ptr+ return s1+ Memory.store (Maybe.fromJust sExit) statePtr+ LLVM.insertvalue Tuple.undef pos TypeNum.d1++ doCreate <- A.cmp LLVM.CmpEQ (LLVM.valueOf 0) phase+ doDelete <- A.cmp LLVM.CmpEQ (LLVM.valueOf 1) phase+ C.ret =<<+ (C.ifThenElse doCreate create $+ C.ifThenElse doDelete delete fill)+++class RunArg a where+ type DSLArg a+ buildArg :: Arg.T a (DSLArg a)++instance RunArg () where+ type DSLArg () = ()+ buildArg = Arg.unit++instance (RunArg a, RunArg b) => RunArg (a,b) where+ type DSLArg (a,b) = (DSLArg a, DSLArg b)+ buildArg = Arg.pair buildArg buildArg++instance (RunArg a, RunArg b, RunArg c) => RunArg (a,b,c) where+ type DSLArg (a,b,c) = (DSLArg a, DSLArg b, DSLArg c)+ buildArg = Arg.triple buildArg buildArg buildArg++instance RunArg Float where+ type DSLArg Float = Exp Float+ buildArg = Arg.primitive++instance RunArg Int where+ type DSLArg Int = Exp Int+ buildArg = Arg.primitive++instance RunArg Word where+ type DSLArg Word = Exp Word+ buildArg = Arg.primitive++instance RunArg Word32 where+ type DSLArg Word32 = Exp Word32+ buildArg = Arg.primitive++instance (RunArg a) => RunArg (Stereo.T a) where+ type DSLArg (Stereo.T a) = Stereo.T (DSLArg a)+ buildArg =+ case buildArg of+ Arg.Cons pass create ->+ Arg.Cons+ (fmap pass . Stereo.unExpression)+ (\s -> do+ pf <- traverse create s+ return (fst<$>pf, traverse_ snd pf))++instance+ (TypeNum.Natural n, Marshal.C a, LLVM.IsSized (Marshal.Struct a),+ TypeNum.Natural (n TypeNum.:*: LLVM.SizeOf (Marshal.Struct a))) =>+ RunArg (MultiValue.Array n a) where+ type DSLArg (MultiValue.Array n a) = Exp (MultiValue.Array n a)+ buildArg = Arg.primitive++instance (Storable.C a) => RunArg (SV.Vector a) where+ type DSLArg (SV.Vector a) = T (MultiValue.T a)+ buildArg =+ Arg.Cons+ Source.storableVector+ (\av -> do+ let (fp,ptr,l) = SVU.unsafeToPointers av+ return (Source.consStorableVector ptr l, touchForeignPtr fp))++newtype Buffer a = Buffer (SV.Vector a)++buffer :: SV.Vector a -> Buffer a+buffer = Buffer++instance (Storable.C a) => RunArg (Buffer a) where+ type DSLArg (Buffer a) = Exp (Source.StorableVector a)+ buildArg =+ Arg.Cons id+ (\(Buffer av) -> do+ let (fp,ptr,l) = SVU.unsafeToPointers av+ return (Source.consStorableVector ptr l, touchForeignPtr fp))++instance (Storable.C a) => RunArg (SVL.Vector a) where+ type DSLArg (SVL.Vector a) = T (MultiValue.T a)+ buildArg =+ Arg.newDispose ChunkIt.new ChunkIt.dispose Source.storableVectorLazy++class TimeInteger int where+ subdivideLong :: EventList.T (NonNeg.T int) a -> EventList.T NonNeg.Int a++instance TimeInteger Int where+ subdivideLong = id++instance TimeInteger Integer where+ subdivideLong = PC.subdivideLongStrict++instance+ (time ~ NonNeg.T int, TimeInteger int, Marshal.C a) =>+ RunArg (EventList.T time a) where+ type DSLArg (EventList.T time a) = T (Const.T (MultiValue.T a))+ buildArg =+ Arg.newDispose+ (EventIt.new . subdivideLong) EventIt.dispose Source.eventList++instance (a ~ SVL.ChunkSize) => RunArg (NonNegChunky.T a) where+ type DSLArg (NonNegChunky.T a) = T (Const.T ())+ buildArg =+ Arg.newDispose SizeIt.new SizeIt.dispose Source.lazySize
src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs view
@@ -55,11 +55,10 @@ import qualified Synthesizer.LLVM.Causal.Helix as Helix import qualified Synthesizer.LLVM.Causal.Functional as F import qualified Synthesizer.LLVM.Causal.ControlledPacked as CtrlPS-import qualified Synthesizer.LLVM.Causal.Render as CausalRender+import qualified Synthesizer.LLVM.Causal.Render as Render import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS-import qualified Synthesizer.LLVM.Generator.Render as Render import qualified Synthesizer.LLVM.Generator.Signal as Sig import qualified Synthesizer.LLVM.Interpolation as Interpolation import qualified Synthesizer.LLVM.Wave as WaveL@@ -203,7 +202,7 @@ proc sampleRate vel freq . Gate.toStorableVector) $- CausalRender.run $+ Render.run $ wrapped $ \(Number vel) (Frequency freq) -> constant time 0.2 $ \halfLife _sr -> Causal.fromSignal $@@ -227,13 +226,13 @@ release sr rel y . Gate.allToChunkySize))- (CausalRender.run $+ (Render.run $ wrapped $ \(Time decay) (Number vel) (SampleRate _sr) -> Causal.fromSignal $ SigPS.exponential2 -- FixMe: is division vectorSize correct? (decay / fromIntegral vectorSize) (amplitudeFromVelocity vel))- (CausalRender.run $+ (Render.run $ wrapped $ \(Time releaseHL) (Number level) -> constant time 1 $ \releaseTime _sr -> Causal.take@@ -248,7 +247,7 @@ osci sr freq . envelope dec rel sr vel)- (CausalRender.run $+ (Render.run $ wrapped $ \(Frequency freq) (SampleRate _sr) -> Causal.envelope $> SigPS.osci WaveL.saw zero freq) pingReleaseEnvelope@@ -271,11 +270,11 @@ release sr y <<^ halfLifeControl sr . Zip.second . Zip.second))- (CausalRender.run $+ (Render.run $ wrapped $ \(Number vel) (SampleRate _sr) -> Exp.causalPacked (amplitudeFromVelocity vel) <<^ Exp.unMultiValueParameterPacked)- (CausalRender.run $+ (Render.run $ wrapped $ \(Number level) (SampleRate _sr) -> let expo = Exp.causalPacked level <<^ Exp.unMultiValueParameterPacked in case threshold of@@ -308,7 +307,7 @@ arr $ halfLifeControl sr))) . zipEnvelope (env sr vel))- (CausalRender.run $+ (Render.run $ constant frequency 10 $ \speed _sr -> (arr Stereo.multiValue .@@ -361,7 +360,7 @@ arr $ transposeModulation sr freq)) . zipEnvelope (env sr vel))- (CausalRender.run $+ (Render.run $ constant frequency 10 $ \speed -> constant frequency 100 $ \lowerFreq _sr -> (arr Stereo.multiValue@@ -413,7 +412,7 @@ arr $ transposeModulation sr freq) . zipEnvelope (env sr vel))- (CausalRender.run $+ (Render.run $ wrapped $ \(Number vel) -> constant frequency 5 $ \speed -> constant time 1 $ \halfLife _sr ->@@ -529,7 +528,7 @@ (envInf sr (vel*4) . Zip.arrowSecond (shortenTimes 7)))))- (CausalRender.run $+ (Render.run $ constant noiseReference 20000 $ \noiseRef -> constant frequency 5 $ \speed _sr -> (F.withArgs $ \((env1,(env4,env7)),((noiseAmp0,noiseReson),fm)) ->@@ -594,17 +593,17 @@ release sr y <<^ halfLifeControl sr . Zip.second . Zip.second))- (CausalRender.run $+ (Render.run $ wrapped $ \(Number amp) (SampleRate _sr) -> Causal.fromSignal (SigPS.constant amp) - takeThreshold 1e-4 . Exp.causalPacked amp <<^ Exp.unMultiValueParameterPacked)- (CausalRender.run $+ (Render.run $ wrapped $ \(Number amp) (SampleRate _sr) -> Causal.fromSignal (SigPS.constant amp))- (CausalRender.run $+ (Render.run $ wrapped $ \(Number level) (SampleRate _sr) -> takeThreshold 0.01 .@@ -641,7 +640,7 @@ arr $ transposeModulation sr freq) . zipEnvelope (env sr vel))- (CausalRender.run $ \sr ->+ (Render.run $ \sr -> F.withArgs $ \(env,(reson,fm)) -> Stereo.multiValue <$> Causal.envelopeStereo $& env &|& windCore reson fm sr)@@ -668,7 +667,7 @@ arr $ transposeModulation sr freq)) . zipEnvelope (env sr vel))- (CausalRender.run $ \sr ->+ (Render.run $ \sr -> (F.withArgs $ \(env,(phaserMix0,(phaserFreq,(reson,fm)))) -> let phaserMix = Causal.map Serial.upsample $& phaserMix0 noise = windCore reson fm sr@@ -722,7 +721,7 @@ arr $ transposeModulation sr freq) . zipEnvelope (env sr vel))- (CausalRender.run $+ (Render.run $ constant frequency 5 $ \speed _sr -> (arr Stereo.multiValue .@@ -800,7 +799,7 @@ arr $ transposeModulation sr freq) . zipEnvelope (env sr vel))- (CausalRender.run $+ (Render.run $ constant frequency 5 $ \speed _sr -> (F.withArgs $ \(env,((depth0,shape0),(det0,fm))) -> let det = Causal.map Serial.upsample $& det0@@ -863,13 +862,13 @@ . (Zip.arrowSecond $ arr $ transposeModulation sr (freq * Sample.period pos))))- (CausalRender.run $ \sr (amp, smp) ->+ (Render.run $ \sr (amp, smp) -> Stereo.multiValue ^<< Causal.stereoFromMono (resamplingProc sr (amp, smp)) <<^ Stereo.unMultiValue)- (CausalRender.run $+ (Render.run $ constant frequency 3 $ \speed _sr -> fmap Stereo.multiValue $ F.withArgs $ stereoFrequenciesFromDetuneBendModulation speed)@@ -894,8 +893,8 @@ freqMod sr . (arr $ transposeModulation sr (freq * Sample.period pos))))- (CausalRender.run resamplingProc)- (CausalRender.run $+ (Render.run resamplingProc)+ (Render.run $ constant frequency 3 $ \speed _sr -> F.withArgs $ frequencyFromBendModulationPacked speed) @@ -984,7 +983,7 @@ makeHelix makeZigZag makeIntegrate- (CausalRender.run $+ (Render.run $ constant frequency 3 $ \speed _sr -> fmap Stereo.multiValue $ F.withArgs $ stereoFrequenciesFromDetuneBendModulation speed)@@ -993,7 +992,7 @@ IO (SampleRate Real -> Real -> Real -> Render.Buffer Real -> PIO.T (Zip.T Chunk StereoChunk) StereoChunk) makeHelix =- CausalRender.run $+ Render.run $ wrapped $ \(Number amp) (Number per) (SampleRate _sr) smp -> arr Stereo.multiValue@@ -1015,7 +1014,7 @@ IO (SampleRate Real -> (Real, Real, Real) -> PIO.T (Control Real) Chunk) makeZigZag =- CausalRender.run $+ Render.run $ wrapped $ \(Number start, Number loopStart, Number loopLength) (SampleRate _sr) -> CausalPS.raise start@@ -1029,7 +1028,7 @@ IO (SampleRate Real -> (Real, Real) -> PIO.T (Control Real) Chunk) makeIntegrate =- CausalRender.run $+ Render.run $ wrapped $ \(Number start, Number stop) (SampleRate _sr) -> Causal.takeWhile (\v -> stop >* Serial.subsample v)
src/Synthesizer/LLVM/Server/Common.hs view
@@ -29,8 +29,8 @@ controllerVolume, ) where -import qualified Synthesizer.LLVM.Generator.Render as Render import qualified Synthesizer.LLVM.Generator.Signal as Sig+import qualified Synthesizer.LLVM.Private.Render as Render import Synthesizer.LLVM.Causal.Process (($*)) import qualified Synthesizer.LLVM.MIDI.BendModulation as BM@@ -44,6 +44,7 @@ import qualified Sound.MIDI.Controller as Ctrl import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified LLVM.DSL.Render.Argument as Arg import qualified LLVM.DSL.Expression as Expr import LLVM.DSL.Expression (Exp) @@ -101,8 +102,8 @@ type DSLArg (SampleRate a) = SampleRate (Render.DSLArg a) buildArg = case Render.buildArg of- Render.BuildArg pass create ->- Render.BuildArg+ Arg.Cons pass create ->+ Arg.Cons (SampleRate . pass) (\(SampleRate sr) -> create sr)
synthesizer-llvm.cabal view
@@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: synthesizer-llvm-Version: 1.0+Version: 1.1 License: GPL-3.0-only License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -58,7 +58,7 @@ default: False Source-Repository this- Tag: 1.0+ Tag: 1.1 Type: darcs Location: http://code.haskell.org/synthesizer/llvm/ @@ -69,7 +69,7 @@ Library Build-Depends:- llvm-dsl >=0.1 && <0.2,+ llvm-dsl >=0.1.1 && <0.2, llvm-extra >=0.11 && <0.12, llvm-tf >=9.0 && <13.0, tfp >=1.0 && <1.1,@@ -175,11 +175,12 @@ Synthesizer.LLVM.Storable.ChunkIterator Synthesizer.LLVM.Storable.LazySizeIterator Synthesizer.LLVM.RingBuffer- Synthesizer.LLVM.Causal.Parameterized+ Synthesizer.LLVM.Causal.Parametric Synthesizer.LLVM.Causal.Private Synthesizer.LLVM.Frame.StereoInterleavedCode Synthesizer.LLVM.Generator.Extra Synthesizer.LLVM.Generator.Private+ Synthesizer.LLVM.Private.Render Synthesizer.LLVM.Private Library server