{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.CausalParameterized.Process ( T(Cons), simple, fromSignal, toSignal, mapAccum, map, mapSimple, zipWith, zipWithSimple, apply, compose, first, feedFst, feedSnd, loop, loopZero, take, takeWhile, integrate, ($<), ($>), ($*), applyFst, applySnd, reparameterize, mapAccumSimple, replicateControlled, replicateParallel, replicateControlledParam, feedbackControlled, Causal.feedbackControlledZero, Causal.fromModifier, stereoFromMono, stereoFromMonoControlled, stereoFromMonoParameterized, Causal.stereoFromVector, Causal.vectorize, Causal.replaceChannel, Causal.arrayElement, Causal.element, Causal.mix, raise, Causal.envelope, Causal.envelopeStereo, amplify, amplifyStereo, mapLinear, mapExponential, quantizeLift, osciSimple, Causal.osciCore, Causal.osciCoreSync, Causal.shapeModOsci, delay, delayZero, delay1, Causal.delay1Zero, delayControlled, delayControlledInterpolated, differentiate, comb, combStereo, reverb, reverbEfficient, Causal.pipeline, Causal.skip, Causal.frequencyModulation, frequencyModulationLinear, trigger, runStorable, applyStorable, runStorableChunky, runStorableChunkyCont, applyStorableChunky, processIO, processIOCore, ) where import Synthesizer.LLVM.CausalParameterized.ProcessPrivate import Synthesizer.LLVM.Causal.ProcessPrivate (feedbackControlledAux, ) import Synthesizer.LLVM.Causal.Process (loopZero, mix, ) import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Plug.Input as PIn import qualified Synthesizer.LLVM.Plug.Output as POut import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.CausalIO.Process as PIO import Synthesizer.LLVM.Parameter (($#), ) import qualified Synthesizer.LLVM.RingBuffer as RingBuffer import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Simple.Signal as Sig import qualified Synthesizer.LLVM.Interpolation as Interpolation import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Execution as Exec import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB import qualified Synthesizer.Generic.Cut as Cut import qualified Synthesizer.Causal.Class as CausalClass import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.MaybeContinuation as MaybeCont import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.ForeignPtr as ForeignPtr import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, ) import LLVM.Core (CodeGenFunction, ret, Value, valueOf, IsSized, IsConst, IsArithmetic, IsFloating, Linkage(ExternalLinkage), createNamedFunction, ) import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal (D1, ) import qualified Control.Monad.HT as M import qualified Control.Category as Cat import qualified Control.Monad.Trans.State as MS import Control.Monad.Trans.State (evalState, ) import Control.Arrow (arr, first, second, (<<<), (<<^), (>>>), (&&&), ) import Control.Monad (liftM, liftM2, liftM3, when, ) import Control.Applicative (liftA2, liftA3, pure, (<*>), ) import Control.Functor.HT (void, unzip, ) import qualified Data.List as List import Data.Traversable (traverse, ) import Data.Foldable (sequence_, ) import Data.Tuple.HT (swap, mapFst, mapSnd, uncurry3, snd3, ) import Data.Word (Word32, ) import Data.Int (Int8, ) import System.Random (Random, RandomGen, randomR, ) import qualified Algebra.Transcendental as Trans import qualified Synthesizer.LLVM.Alloc as Alloc import qualified System.Unsafe as Unsafe import qualified Foreign.Marshal.Utils as AllocUtil import qualified Foreign.Concurrent as FC import Foreign.Storable.Tuple () import Foreign.Storable (Storable, poke, peek, ) import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, ) import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, ) import Foreign.Ptr (FunPtr, Ptr, castPtr, freeHaskellFunPtr, ) import Control.Exception (bracket, ) import qualified Synthesizer.LLVM.Debug.Storable as DebugSt import qualified Synthesizer.LLVM.Debug.Counter as DebugCnt import NumericPrelude.Numeric import NumericPrelude.Base hiding (and, iterate, map, unzip, zip, zipWith, take, takeWhile, sequence_, ) infixl 0 $<, $>, $* -- infixr 0 $:* -- can be used together with $ applyFst, ($<) :: T p (a,b) c -> SigP.T p a -> T p b c applyFst = CausalClass.applyFst applySnd, ($>) :: T p (a,b) c -> SigP.T p b -> T p a c applySnd = CausalClass.applySnd {- These infix operators may become methods of a type class that can also have synthesizer-core:Causal.Process as instance. -} ($*) :: T p a b -> SigP.T p a -> SigP.T p b ($*) = apply ($<) = applyFst ($>) = applySnd reparameterize :: Param.T q p -> T p a b -> T q a b reparameterize p (Cons start stop next create delete) = Cons start stop next (create . Param.get p) delete mapAccumSimple :: (Memory.C s) => (forall r. a -> s -> CodeGenFunction r (b,s)) -> (forall r. CodeGenFunction r s) -> T p a b mapAccumSimple f s = mapAccum (\() -> f) (\() -> s) (return ()) (return ()) replicateParallel :: (Undefined b, Phi b) => Param.T p Int -> SigP.T p b -> T p (b,b) b -> T p a b -> T p a b replicateParallel n z cum p = replicateControlled n (first p >>> cum) $> z {- There are several problems: * We have to call f on every parameter in the list, but we have to assume that the generated code is always the same. * createIOContext may return different types for every element in the list. If types are different, the LLVM code cannot be the same, though. -} replicateControlledParam :: (Undefined x, Phi x) => (forall q. Param.T q p -> Param.T q a -> T q (c,x) x) -> Param.T p [a] -> T p (c,x) x replicateControlledParam f ps = case f (arr fst) (arr snd) of Cons next start stop createIOContext deleteIOContext -> Cons (replicateControlledNext next stop) -- (_replicateControlledNext next) (replicateControlledStart start) (replicateControlledStop stop) (\p -> replicateControlledCreate $ mapM (\a -> createIOContext (p,a)) (Param.get ps p)) (replicateControlledDelete deleteIOContext) -- cf. synthesizer-core:Causal.Process feedbackControlled :: (Storable ch, MakeValueTuple ch, ValueTuple ch ~ c, Memory.C c) => Param.T p ch -> T p ((ctrl,a),c) b -> T p (ctrl,b) c -> T p (ctrl,a) b feedbackControlled initial forth back = loop initial (feedbackControlledAux forth back) {- | Run a causal process independently on each stereo channel. -} stereoFromMono :: (Phi a, Phi b, Undefined b) => T p a b -> T p (Stereo.T a) (Stereo.T b) stereoFromMono (Cons next start stop createIOContext deleteIOContext) = Cons (stereoNext stop next) (stereoStart start) (stereoStop stop) (stereoCreate createIOContext createIOContext) (composeDelete deleteIOContext deleteIOContext) stereoFromMonoControlled :: (Phi a, Phi b, Phi c, Undefined b) => T p (c,a) b -> T p (c, Stereo.T a) (Stereo.T b) stereoFromMonoControlled proc = stereoFromMono proc <<^ (\(c,sa) -> fmap ((,) c) sa) stereoFromMonoParameterized :: (Phi a, Phi b, Undefined b) => (forall q. Param.T q p -> Param.T q x -> T q a b) -> Param.T p (Stereo.T x) -> T p (Stereo.T a) (Stereo.T b) stereoFromMonoParameterized f ps = case f (arr fst) (arr snd) of Cons next start stop createIOContext deleteIOContext -> Cons (stereoNext stop next) (stereoStart start) (stereoStop stop) (stereoCreate (\p -> createIOContext (p, Stereo.left $ Param.get ps p)) (\p -> createIOContext (p, Stereo.right $ Param.get ps p))) (composeDelete deleteIOContext deleteIOContext) stereoCreate :: Monad m => (p -> m (ioContextA, context)) -> (p -> m (ioContextB, context)) -> p -> m ((ioContextA, ioContextB), Stereo.T context) stereoCreate l r = liftM (mapSnd $ uncurry Stereo.cons) . composeCreate l r stereoNext :: (Phi a, Phi b, Phi c, Phi s, Phi context, Undefined b, Undefined s) => (context -> s -> CodeGenFunction r ()) -> (forall z. (Phi z) => context -> a -> s -> MaybeCont.T r z (b, s)) -> Stereo.T context -> Stereo.T a -> Stereo.T s -> MaybeCont.T r c (Stereo.T b, Stereo.T s) stereoNext stop next context a s0 = MaybeCont.fromMaybe $ do mbs1 <- twiceStereo (MaybeCont.toMaybe . uncurry3 next) (liftA3 (,,) context a s0) mbs2 <- if True then Maybe.lift2 Stereo.cons (Stereo.left mbs1) (Stereo.right mbs1) else MaybeCont.toMaybe $ traverse (MaybeCont.fromMaybe . return) mbs1 end <- Maybe.getIsNothing mbs2 C.ifThen end () $ sequence_ $ liftA2 (\mbsi c -> Maybe.for mbsi (stop c . snd)) mbs1 context return $ fmap unzip mbs2 stereoStart :: (Phi a, Phi b, Phi c, Undefined b, Undefined c) => (a -> CodeGenFunction r (c, b)) -> Stereo.T a -> CodeGenFunction r (Stereo.T c, Stereo.T b) stereoStart code a = fmap unzip $ twiceStereo code a stereoStop :: (Phi context, Phi state) => (context -> state -> CodeGenFunction r ()) -> Stereo.T context -> Stereo.T state -> CodeGenFunction r () stereoStop code c s = void $ twiceStereo (uncurry code) (liftA2 (,) c s) twiceStereo :: (Phi a, Phi b, Undefined b) => (a -> CodeGenFunction r b) -> Stereo.T a -> CodeGenFunction r (Stereo.T b) twiceStereo code a = fmap (uncurry Stereo.cons) $ twice code (Stereo.left a, Stereo.right a) twice :: (Phi a, Phi b, Undefined b) => (a -> CodeGenFunction r b) -> (a,a) -> CodeGenFunction r (b,b) twice code a = fmap snd $ C.fixedLengthLoop (valueOf (2::Int8)) (a, undefTuple) $ \((a0,a1), (_,b1)) -> do b0 <- code a0 return ((a1,a0), (b1,b0)) {- | You may also use '(+)' and a 'SigP.constant' signal or a number literal. -} raise :: (A.Additive al, Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p al al raise = map Frame.mix {- | You may also use '(*)' and a 'SigP.constant' signal or a number literal. -} amplify :: (A.PseudoRing al, Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p al al amplify = map Frame.amplifyMono amplifyStereo :: (A.PseudoRing al, Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p (Stereo.T al) (Stereo.T al) amplifyStereo = map Frame.amplifyStereo mapLinear :: (IsArithmetic a, Storable a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, MakeValueTuple a, ValueTuple a ~ (Value a)) => Param.T p a -> Param.T p a -> T p (Value a) (Value a) mapLinear depth center = map (\(d,c) x -> A.add c =<< A.mul d x) (depth&&¢er) mapExponential :: (Trans.C a, IsFloating a, IsConst a, Storable a, SoV.TranscendentalConstant a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, MakeValueTuple a, ValueTuple a ~ (Value a)) => Param.T p a -> Param.T p a -> T p (Value a) (Value a) mapExponential depth center = map (\(d,c) x -> A.mul c =<< A.exp =<< A.mul d x) (log depth &&& center) {- | @quantizeLift k f@ applies the process @f@ to every @k@th sample and repeats the result @k@ times. Like 'SigP.interpolateConstant' this function can be used for computation of filter parameters at a lower rate. This can be useful, if you have a frequency control signal at sample rate that shall be used both for an oscillator and a frequency filter. -} quantizeLift :: (Memory.C b, Storable c, MakeValueTuple c, ValueTuple c ~ Value cl, SoV.IntegerConstant cl, IsFloating cl, LLVM.CmpRet cl, LLVM.CmpResult cl ~ Bool, Memory.FirstClass cl, Memory.Stored cl ~ cm, IsSized cm) => Param.T p c -> T p a b -> T p a b quantizeLift k causal = Causal.quantizeLift causal $< SigP.constant k -- for backwards compatibility osciSimple :: (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm, SoV.Fraction t) => (forall r. Value t -> CodeGenFunction r y) -> T p (Value t, Value t) y osciSimple = Causal.osci {- | Delay time must be non-negative. The initial value is needed in order to determine the ring buffer element type. -} delay :: (Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> Param.T p Int -> T p al al delay initial time = mapSimple RingBuffer.oldest <<< RingBuffer.track initial time delayZero :: (Memory.C a, A.Additive a) => Param.T p Int -> T p a a delayZero time = mapSimple RingBuffer.oldest <<< RingBuffer.trackConst A.zero time {- | Delay by one sample. For very small delay times (say up to 8) it may be more efficient to apply 'delay1' several times or to use a pipeline, e.g. @pipeline (id :: T (Vector D4 Float) (Vector D4 Float))@ delays by 4 samples in an efficient way. In principle it would be also possible to use @unpack (delay1 (const $ toVector (0,0,0,0)))@ but 'unpack' causes an additional delay. Thus @unpack (id :: T (Vector D4 Float) (Vector D4 Float))@ may do, what you want. -} delay1 :: (Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p al al delay1 initial = loop initial (arr swap) {- | Delay by a variable amount of samples. The momentum delay must be between @0@ and @maxTime@, inclusively. -} delayControlled :: (Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> Param.T p Int -> T p (Value Word32, al) al delayControlled initial maxTime = zipWithSimple RingBuffer.index <<< second (RingBuffer.track initial maxTime) {- | Delay by a variable fractional amount of samples. Non-integer delays are achieved by linear interpolation. The momentum delay must be between @0@ and @maxTime@, inclusively. -} delayControlledInterpolated :: (Interpolation.C nodes, Storable vh, MakeValueTuple vh, ValueTuple vh ~ v, Memory.C v, IsFloating a, LLVM.NumberOfElements a ~ TypeNum.D1) => (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 = let margin = Interpolation.toMargin ip in zipWithSimple (\del buf -> do let offset = A.fromInteger' $ fromIntegral $ Interpolation.marginOffset margin n <- A.max offset =<< LLVM.fptoint del k <- A.sub del =<< LLVM.inttofp n m <- A.sub n offset ip k =<< Interpolation.indexNodes (flip RingBuffer.index buf) A.one m) <<< second (RingBuffer.track initial (fmap (Interpolation.marginNumber margin +) maxTime)) differentiate :: (A.Additive al, Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> T p al al differentiate initial = Cat.id - delay1 initial {- | Delay time must be greater than zero! -} comb :: (A.PseudoRing al, Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> Param.T p Int -> T p al al comb gain time = loopZero (mix >>> (Cat.id &&& (delayZero (subtract 1 time) >>> amplify gain))) combStereo :: (A.PseudoRing al, Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) => Param.T p a -> Param.T p Int -> T p (Stereo.T al) (Stereo.T al) combStereo gain time = loopZero (mix >>> (Cat.id &&& (delayZero (subtract 1 time) >>> amplifyStereo gain))) {- | Example: apply a stereo reverb to a mono sound. > traverse > (\seed -> reverb (Random.mkStdGen seed) 16 (0.92,0.98) (200,1000)) > (Stereo.cons 42 23) -} reverb :: (Random a, IsArithmetic a, SoV.RationalConstant a, MakeValueTuple a, ValueTuple a ~ (Value a), Storable a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, RandomGen g) => g -> Int -> (a,a) -> (Int,Int) -> T p (Value a) (Value a) reverb rnd num gainRange timeRange = mapSimple (A.mul (A.fromRational' $ recip $ fromIntegral num)) <<< (foldl (+) Cat.id $ List.map (\(g,t) -> comb $# g $# t) $ reverbParams rnd num gainRange timeRange) reverbEfficient :: (Random a, SoV.PseudoModule a, SoV.Scalar a ~ s, IsFloating s, SoV.IntegerConstant s, LLVM.NumberOfElements s ~ D1, MakeValueTuple a, ValueTuple a ~ Value a, Storable a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, RandomGen g) => Param.T p g -> Param.T p Int -> Param.T p (a,a) -> Param.T p (Int,Int) -> T p (Value a) (Value a) reverbEfficient rnd num gainRange timeRange = map (\n x -> flip A.scale x =<< A.fdiv A.one =<< LLVM.inttofp n) (Param.word32 num) <<< replicateControlledParam (\_p p -> first (comb (fmap fst p) (fmap snd p)) >>> mix) (pure reverbParams <*> rnd <*> num <*> gainRange <*> timeRange) <<^ (\a -> (a,a)) reverbParams :: (RandomGen g, Random a) => g -> Int -> (a, a) -> (Int, Int) -> [(a, Int)] reverbParams rnd num gainRange timeRange = List.take num $ flip evalState rnd $ M.repeat $ liftM2 (,) (MS.state (randomR gainRange)) (MS.state (randomR timeRange)) {- | Like 'skip' but does not require @Memory@ constraint on the result type. This way it can be used on a stream of ring buffer states. The downside is that the result is recomputed (from the previous state) at every step. Warning: This process is actually unsafe. It fails on signal generators that use mutable variables, like Signal.storableVectorLazy. -} _skipVolatile :: (Causal.C process, CausalClass.SignalOf process ~ signal) => signal v -> process (Value Word32) v _skipVolatile = Causal.alterSignal (\(Sig.Core next start stop) -> Causal.Core (\context n state0 -> do y <- fmap fst $ next context state0 state1 <- MaybeCont.fromMaybe $ fmap snd $ MaybeCont.fixedLengthLoop n state0 $ fmap snd . next context return (y, state1)) start stop) {- | > frequencyModulationLinear signal is a causal process mapping from a shrinking factor to the modulated input @signal@. Similar to 'Sig.interpolateConstant' but the factor is reciprocal and controllable and we use linear interpolation. The shrinking factor must be non-negative. -} frequencyModulationLinear :: (SoV.IntegerConstant a, IsFloating a, LLVM.CmpRet a, LLVM.CmpResult a ~ Bool, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am) => SigP.T p (Value a) -> T p (Value a) (Value a) frequencyModulationLinear = Causal.frequencyModulation Interpolation.linear . SigP.adjacentNodes02 type Exporter f = f -> IO (FunPtr f) foreign import ccall safe "wrapper" callbackCreate :: Exporter (Ptr lparam -> Ptr init -> IO (StablePtr ioContext)) foreign import ccall safe "wrapper" callbackDelete :: Exporter (StablePtr ioContext -> IO ()) stopAndDelete :: LLVM.Function (StablePtr ioContext -> IO ()) -> (context -> state -> CodeGenFunction r ()) -> Maybe.T ((context, state), Value (StablePtr ioContext)) -> CodeGenFunction r () stopAndDelete eraser stop mcsio = Maybe.for mcsio $ \(cs, io) -> do uncurry stop cs void $ LLVM.call eraser io castBackStorablePtr :: (MakeValueTuple haskellValue, ValueTuple haskellValue ~ llvmValue, Memory.C llvmValue) => Ptr (Memory.Struct (ValueTuple haskellValue)) -> Ptr haskellValue castBackStorablePtr = castPtr {- | @trigger fill signal@ send @signal@ to the output and restart it whenever the Boolean process input is 'True'. Before the first occurrence of 'True' and between instances of the signal the output is filled with 'Maybe.nothing'. Every restart of the signal needs a call into Haskell code. Thus it is certainly a good idea, not to trigger the signal too frequently. -} {- Are exceptions handled correctly? -} trigger :: (Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al, Undefined b, Phi b) => (forall q. Param.T q p -> Param.T q a -> SigP.T q b) -> T p (Maybe.T al) (Maybe.T b) trigger sig = triggerAux (sig (arr fst) (arr snd)) triggerAux :: (Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al, Undefined b, Phi b) => SigP.T (p,a) b -> T p (Maybe.T al) (Maybe.T b) triggerAux (SigP.Cons next start stop createIOContext deleteIOContext) = Cons (\(creator, eraser) mx mcsio0 -> MaybeCont.lift $ do mcsio1 <- Maybe.run mx (return mcsio0) (\x -> stopAndDelete eraser stop mcsio0 >> do param <- LLVM.alloca xPtr <- LLVM.alloca Memory.store x xPtr io <- LLVM.call creator param xPtr cs <- start =<< Memory.load param return $ Maybe.just (cs, io)) mcasio2 <- Maybe.run mcsio1 (return Maybe.nothing) $ \((c1,s1), io1) -> MaybeCont.toMaybe $ fmap (flip (,) io1 . (,) c1) $ next c1 s1 return (fmap (fst.snd.fst) mcasio2, fmap (mapFst (mapSnd snd)) mcasio2)) (\ce -> return (ce, Maybe.nothing)) (\(_creator, eraser) mcsio -> stopAndDelete eraser stop mcsio) (\p -> do creator <- callbackCreate $ \paramPtr xPtr -> do x <- peek (castBackStorablePtr xPtr) (context, param) <- createIOContext (p,x) poke (castBackStorablePtr paramPtr) param newStablePtr context eraser <- callbackDelete $ \contextPtr -> do deleteIOContext =<< deRefStablePtr contextPtr freeStablePtr contextPtr let ce = (creator, eraser) return (ce, ce)) (\(creator, eraser) -> freeHaskellFunPtr creator >> freeHaskellFunPtr eraser) {- | On each restart the parameters of type @b@ are passed to the signal. triggerParam :: (MakeValueTuple a, ValueTuple a ~ al, MakeValueTuple b, ValueTuple b ~ bl) => Param.T p a -> (Param.T p b -> SigP.T p a) -> T p (Value Bool, bl) al triggerParam fill sig = -} foreign import ccall safe "dynamic" derefFillPtr :: Exec.Importer (Ptr param -> Word32 -> Ptr a -> Ptr b -> IO Word32) runStorable :: (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T p valueA valueB -> IO (p -> SV.Vector a -> SV.Vector b) runStorable (Cons next start stop createIOContext deleteIOContext) = do fill <- fmap derefFillPtr $ Exec.compileModule $ createNamedFunction ExternalLinkage "fillprocessblock" $ \paramPtr size alPtr blPtr -> do param <- Memory.load paramPtr (c,s) <- start param (pos,msExit) <- MaybeCont.arrayLoop2 size alPtr blPtr s $ \ aPtri bPtri s0 -> do a <- MaybeCont.lift $ Memory.load aPtri (b,s1) <- next c a s0 MaybeCont.lift $ Memory.store b bPtri return s1 Maybe.for msExit $ stop c ret (pos :: Value Word32) return $ \p as -> Unsafe.performIO $ bracket (createIOContext p) (deleteIOContext . fst) $ \ (_,params) -> SVB.withStartPtr as $ \ aPtr len -> SVB.createAndTrim len $ \ bPtr -> Alloc.with params $ \paramPtr -> fmap fromIntegral $ fill (Memory.castStorablePtr paramPtr) (fromIntegral len) (Memory.castStorablePtr aPtr) (Memory.castStorablePtr bPtr) applyStorable :: (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T p valueA valueB -> p -> SV.Vector a -> SV.Vector b applyStorable gen = Unsafe.performIO $ runStorable gen foreign import ccall safe "dynamic" derefChunkPtr :: Exec.Importer (Ptr contextStateStruct -> Word32 -> Ptr structA -> Ptr structB -> IO Word32) compileChunky :: (Memory.C valueA, Memory.Struct valueA ~ structA, Memory.C valueB, Memory.Struct valueB ~ structB, Memory.C parameters, Memory.Struct parameters ~ paramStruct, Memory.C context, Memory.C state, Memory.Struct (context, Maybe.T state) ~ contextStateStruct) => (forall r z. (Phi z) => context -> valueA -> state -> MaybeCont.T r z (valueB, state)) -> (forall r. parameters -> CodeGenFunction r (context, state)) -> (forall r. context -> state -> CodeGenFunction r ()) -> IO (FunPtr (Ptr paramStruct -> IO (Ptr contextStateStruct)), FunPtr (Ptr contextStateStruct -> IO ()), FunPtr (Ptr contextStateStruct -> Word32 -> Ptr structA -> Ptr structB -> IO Word32)) compileChunky next start stop = Exec.compileModule $ liftM3 (,,) (createNamedFunction ExternalLinkage "startprocess" $ \paramPtr -> do pptr <- LLVM.malloc flip Memory.store pptr . mapSnd Maybe.just =<< start =<< Memory.load paramPtr ret pptr) (createNamedFunction ExternalLinkage "stopprocess" $ \ contextStatePtr -> do (c,ms) <- Memory.load contextStatePtr Maybe.for ms $ stop c LLVM.free contextStatePtr ret ()) (createNamedFunction ExternalLinkage "fillprocess" $ \ contextStatePtr loopLen aPtr bPtr -> do (param, msInit) <- Memory.load contextStatePtr (pos,msExit) <- Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit -> MaybeCont.arrayLoop2 loopLen aPtr bPtr sInit $ \ aPtri bPtri s0 -> do a <- MaybeCont.lift $ Memory.load aPtri (b,s1) <- next param a s0 MaybeCont.lift $ Memory.store b bPtri return s1 sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ()) Memory.store msExit sptr ret (pos :: Value Word32)) foreign import ccall safe "dynamic" derefStartParamPtr :: Exec.Importer (Ptr paramStruct -> IO (Ptr contextStateStruct)) foreign import ccall safe "dynamic" derefStopPtr :: Exec.Importer (Ptr contextStateStruct -> IO ()) compilePlugged :: (Memory.C parameters, Memory.Struct parameters ~ paramStruct, Memory.C context, Memory.C state, Memory.Struct (context, Maybe.T state) ~ contextStateStruct, Undefined stateIn, Phi stateIn, Undefined stateOut, Phi stateOut, Memory.C paramValueIn, Memory.Struct paramValueIn ~ paramStructIn, Memory.C paramValueOut, Memory.Struct paramValueOut ~ paramStructOut) => (forall r. paramValueIn -> stateIn -> LLVM.CodeGenFunction r (valueA, stateIn)) -> (forall r. paramValueIn -> LLVM.CodeGenFunction r stateIn) -> (forall r z. (Phi z) => context -> valueA -> state -> MaybeCont.T r z (valueB, state)) -> (forall r. parameters -> CodeGenFunction r (context, state)) -> (forall r. context -> state -> CodeGenFunction r ()) -> (forall r. paramValueOut -> valueB -> stateOut -> LLVM.CodeGenFunction r stateOut) -> (forall r. paramValueOut -> LLVM.CodeGenFunction r stateOut) -> IO (FunPtr (Ptr paramStruct -> IO (Ptr contextStateStruct)), FunPtr (Ptr contextStateStruct -> IO ()), FunPtr (Ptr contextStateStruct -> Word32 -> Ptr paramStructIn -> Ptr paramStructOut -> IO Word32)) compilePlugged nextIn startIn next start stop nextOut startOut = Exec.compileModule $ liftM3 (,,) (createNamedFunction ExternalLinkage "startprocess" $ \paramPtr -> do pptr <- LLVM.malloc flip Memory.store pptr . mapSnd Maybe.just =<< start =<< Memory.load paramPtr ret pptr) (createNamedFunction ExternalLinkage "stopprocess" $ \ contextStatePtr -> do (c,ms) <- Memory.load contextStatePtr Maybe.for ms $ stop c LLVM.free contextStatePtr ret ()) (createNamedFunction ExternalLinkage "fillprocess" $ \ contextStatePtr loopLen inPtr outPtr -> do (param, msInit) <- Memory.load contextStatePtr inParam <- Memory.load inPtr outParam <- Memory.load outPtr inInit <- startIn inParam outInit <- startOut outParam (pos,msExit) <- Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit -> MaybeCont.fixedLengthLoop loopLen (inInit, sInit, outInit) $ \ (in0,s0,out0) -> do (a,in1) <- MaybeCont.lift $ nextIn inParam in0 (b,s1) <- next param a s0 out1 <- MaybeCont.lift $ nextOut outParam b out0 return (in1, s1, out1) sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ()) Memory.store (fmap snd3 msExit) sptr ret (pos :: Value Word32)) runStorableChunky :: (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T p valueA valueB -> IO (p -> SVL.Vector a -> SVL.Vector b) runStorableChunky proc = fmap ($ const SVL.empty) $ runStorableChunkyCont proc {- | This function should be used instead of @StorableVector.Lazy.Pattern.splitAt@ and subsequent @append@, because it does not have the risk of a memory leak. -} runStorableChunkyCont :: (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T p valueA valueB -> IO ((SVL.Vector a -> SVL.Vector b) -> p -> SVL.Vector a -> SVL.Vector b) runStorableChunkyCont (Cons next start stop createIOContext deleteIOContext) = do (startFunc, stopFunc, fill) <- compileChunky next start stop return $ \ procRest p sig -> SVL.fromChunks $ Unsafe.performIO $ do (ioContext, param) <- createIOContext p when False $ DebugCnt.with DebugSt.dumpCounter $ do DebugSt.dump "param" param statePtr <- ForeignPtr.newParam stopFunc startFunc param concStatePtr <- withForeignPtr statePtr $ flip FC.newForeignPtr (deleteIOContext ioContext) let go xt = Unsafe.interleaveIO $ case xt of [] -> return [] x:xs -> SVB.withStartPtr x $ \aPtr size -> do v <- withForeignPtr statePtr $ \sptr -> SVB.createAndTrim size $ fmap fromIntegral . derefChunkPtr fill sptr (fromIntegral size) (Memory.castStorablePtr aPtr) . Memory.castStorablePtr touchForeignPtr concStatePtr (if SV.length v > 0 then fmap (v:) else id) $ (if SV.length v < size then return $ SVL.chunks $ procRest $ SVL.fromChunks $ SV.drop (SV.length v) x : xs else go xs) go (SVL.chunks sig) applyStorableChunky :: (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T p valueA valueB -> p -> SVL.Vector a -> SVL.Vector b applyStorableChunky gen = Unsafe.performIO (runStorableChunky gen) {- I liked to write something with signature > import qualified Synthesizer.Causal.Process as Causal > > liftStorableChunk :: > T p valueA valueB -> > IO (p -> Causal.T (SV.Vector a) (SV.Vector b)) but it does not quite work this way. @Causal.T@ from @synthesizer-core@ uses an immutable state internally, whereas @T@ uses mutable states. In principle the immutable state of @Causal.T@ could be used for breaking the processing of a stream and continue it on two different streams in parallel. I have no function that makes use of this feature, and thus an @ST@ monad might be a way out. With this function we can convert an LLVM causal process to an causal IO arrow. We also need the plugs in order to read and write LLVM values from and to Haskell data chunks. In a second step we could convert this to a processor of lazy lists, and thus to a processor of chunky storable vectors. -} processIOCore :: (Cut.Read a) => PIn.T a b -> T p b c -> POut.T c d -> IO (p -> PIO.T a d) processIOCore (PIn.Cons nextIn startIn createIn deleteIn) (Cons next start stop createIOContext deleteIOContext) (POut.Cons nextOut startOut createOut deleteOut) = do (startFunc, stopFunc, fill) <- compilePlugged nextIn startIn next start stop nextOut startOut return $ \p -> PIO.Cons (\a s@(_, paramPtr) -> do let maximumSize = Cut.length a (contextIn, paramIn) <- createIn a (contextOut,paramOut) <- createOut maximumSize actualSize <- AllocUtil.with paramIn $ \inptr -> AllocUtil.with paramOut $ \outptr -> derefChunkPtr fill paramPtr (fromIntegral maximumSize) (Memory.castStorablePtr inptr) (Memory.castStorablePtr outptr) deleteIn contextIn b <- deleteOut (fromIntegral actualSize) contextOut return (b, s)) (do (ioContext, param) <- createIOContext p when False $ DebugCnt.with DebugSt.dumpCounter $ do DebugSt.dump "param" param contextStatePtr <- AllocUtil.with param (derefStartParamPtr startFunc . Memory.castStorablePtr) return (ioContext, contextStatePtr)) (\(ioContext, contextStatePtr) -> do derefStopPtr stopFunc contextStatePtr deleteIOContext ioContext) processIO :: (Cut.Read a, PIn.Default a, POut.Default d) => T p (PIn.Element a) (POut.Element d) -> IO (p -> PIO.T a d) processIO proc = processIOCore PIn.deflt proc POut.deflt