{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Causal.Process ( C(simple, alter, replicateControlled), T, Core(Core), alterSignal, amplify, amplifyStereo, apply, applyFst, applySnd, applyConst, applyConstFst, applyConstSnd, (CausalClass.$<), (CausalClass.$>), (CausalClass.$*), ($<#), ($>#), ($*#), feedFst, feedSnd, feedConstFst, feedConstSnd, first, envelope, envelopeStereo, fromModifier, fromSignal, toSignal, loopConst, loopZero, delay1Zero, feedbackControlledZero, map, mapAccum, zipWith, mapProc, zipProcWith, mix, pipeline, stereoFromVector, vectorize, replaceChannel, arrayElement, element, osciCoreSync, osciCore, osci, shapeModOsci, skip, frequencyModulation, interpolateConstant, quantizeLift, applyStorable, applyStorableChunky, runStorableChunky, ) where import qualified Synthesizer.LLVM.Simple.Signal as Sig import qualified Synthesizer.LLVM.Simple.Value as Value import qualified Synthesizer.LLVM.Causal.ProcessPrivate as Causal import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Execution as Exec import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.Causal.Class as CausalClass import qualified Synthesizer.Causal.Utility as ArrowUtil import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import qualified Data.StorableVector.Base as SVB import qualified LLVM.Extra.Multi.Vector as MultiVector import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.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 LLVM.Extra.Class (Undefined, MakeValueTuple, ValueTuple, ) import qualified LLVM.Core as LLVM import LLVM.ExecutionEngine (simpleFunction, ) import LLVM.Util.Loop (Phi, ) import LLVM.Core (CodeGenFunction, ret, Value, valueOf, IsConst, IsFirstClass, IsArithmetic, IsPrimitive, Linkage(ExternalLinkage), createNamedFunction) import qualified Type.Data.Num.Decimal as TypeNum import Type.Base.Proxy (Proxy, ) import Type.Data.Num.Decimal (D2, (:<:), ) import qualified Control.Arrow as Arr import qualified Control.Category as Cat import Control.Monad.Trans.State (runState, ) import Control.Arrow (arr, (<<<), (>>>), (&&&), ) import Control.Monad (liftM2, liftM3, ) import Control.Applicative (Applicative, pure, (<*>), ) import qualified Data.List as List import Data.Tuple.HT (swap, ) import Data.Word (Word32, ) import Foreign.Storable (Storable, ) import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, ) import Foreign.Ptr (FunPtr, Ptr, ) import Control.Exception (bracket, ) import qualified System.Unsafe as Unsafe import qualified Number.Ratio as Ratio import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive import NumericPrelude.Numeric import NumericPrelude.Base hiding (and, map, zip, zipWith, init, ) import qualified Prelude as P data T a b = forall state ioContext. (Memory.C state) => Cons (forall r c. (Phi c) => ioContext -> a -> state -> MaybeCont.T r c (b, state)) -- compute next value (forall r. ioContext -> CodeGenFunction r state) -- initial state (IO ioContext) -- initialization from IO monad (ioContext -> IO ()) -- finalization from IO monad data Core context initState exitState a b = forall state. (Memory.C state) => Core (forall r c. (Phi c) => context -> a -> state -> MaybeCont.T r c (b, state)) -- compute next value (forall r. initState -> CodeGenFunction r state) -- initial state (state -> exitState) -- extract final state for cleanup class CausalClass.C process => C process where simple :: (Memory.C state) => (forall r c. (Phi c) => a -> state -> MaybeCont.T r c (b, state)) -> (forall r. CodeGenFunction r state) -> process a b alter :: (forall context initState exitState. Core context initState exitState a0 b0 -> Core context initState exitState a1 b1) -> process a0 b0 -> process a1 b1 replicateControlled :: (Undefined x, Phi x) => Int -> process (c,x) x -> process (c,x) x instance CausalClass.C T where type SignalOf T = Sig.T type ProcessOf Sig.T = T toSignal = toSignal fromSignal = fromSignal instance C T where simple next start = Cons (const next) (const start) (return ()) (const $ return ()) alter f (Cons next0 start0 create delete) = case f (Core next0 start0 id) of Core next1 start1 _ -> Cons next1 start1 create delete {- Could be implemented with a machine code loop like in CausalParameterized. But to this end we would need a 'stop' function. -} replicateControlled = CausalClass.replicateControlled toSignal :: T () a -> Sig.T a toSignal (Cons next start createIOContext deleteIOContext) = Sig.Cons (\ioContext -> next ioContext ()) start createIOContext deleteIOContext fromSignal :: Sig.T b -> T a b fromSignal (Sig.Cons next start createIOContext deleteIOContext) = Cons (\ioContext _ -> next ioContext) start createIOContext deleteIOContext map :: (C process) => (forall r. a -> CodeGenFunction r b) -> process a b map f = mapAccum (\a s -> fmap (flip (,) s) $ f a) (return ()) mapAccum :: (C process, Memory.C state) => (forall r. a -> state -> CodeGenFunction r (b, state)) -> (forall r. CodeGenFunction r state) -> process a b mapAccum next = simple (\a s -> MaybeCont.lift $ next a s) zipWith :: (C process) => (forall r. a -> b -> CodeGenFunction r c) -> process (a,b) c zipWith f = map (uncurry f) mapProc :: (C process) => (forall r. b -> CodeGenFunction r c) -> process a b -> process a c mapProc f x = map f <<< x zipProcWith :: (C process) => (forall r. b -> c -> CodeGenFunction r d) -> process a b -> process a c -> process a d zipProcWith f x y = zipWith f <<< x&&&y fromModifier :: (C process) => (Value.Flatten ah, Value.Registers ah ~ al, Value.Flatten bh, Value.Registers bh ~ bl, Value.Flatten ch, Value.Registers ch ~ cl, Value.Flatten sh, Value.Registers sh ~ sl, Memory.C sl) => Modifier.Simple sh ch ah bh -> process (cl,al) bl fromModifier (Modifier.Simple initial step) = mapAccum (\(c,a) s -> Value.flatten $ runState (step (Value.unfold c) (Value.unfold a)) (Value.unfold s)) (Value.flatten initial) apply :: T a b -> Sig.T a -> Sig.T b apply = CausalClass.apply feedFst :: Sig.T a -> T b (a,b) feedFst = CausalClass.feedFst feedSnd :: Sig.T a -> T b (b,a) feedSnd = CausalClass.feedSnd feedConstFst :: (MakeValueTuple a, ValueTuple a ~ al) => a -> T b (al,b) feedConstFst = CausalClass.feedConstFst . Class.valueTupleOf feedConstSnd :: (MakeValueTuple a, ValueTuple a ~ al) => a -> T b (b,al) feedConstSnd = CausalClass.feedConstSnd . Class.valueTupleOf applyFst :: T (a,b) c -> Sig.T a -> T b c applyFst = CausalClass.applyFst applySnd :: T (a,b) c -> Sig.T b -> T a c applySnd = CausalClass.applySnd applyConst :: (MakeValueTuple a, ValueTuple a ~ al) => T al b -> a -> Sig.T b applyConst proc = CausalClass.applyConst proc . Class.valueTupleOf applyConstFst :: (MakeValueTuple a, ValueTuple a ~ al) => T (al,b) c -> a -> T b c applyConstFst proc = CausalClass.applyConstFst proc . Class.valueTupleOf applyConstSnd :: (MakeValueTuple b, ValueTuple b ~ bl) => T (a,bl) c -> b -> T a c applyConstSnd proc = CausalClass.applyConstSnd proc . Class.valueTupleOf infixl 0 $<#, $>#, $*# {- | provide constant input in a comfortable way -} ($*#) :: (C process, CausalClass.SignalOf process ~ signal, Storable ah, MakeValueTuple ah, ValueTuple ah ~ a, Memory.C a) => process a b -> ah -> signal b proc $*# x = CausalClass.applyConst proc $ Class.valueTupleOf x ($<#) :: (C process, Storable ah, MakeValueTuple ah, ValueTuple ah ~ a, Memory.C a) => process (a,b) c -> ah -> process b c proc $<# x = CausalClass.applyConstFst proc $ Class.valueTupleOf x ($>#) :: (C process, Storable bh, MakeValueTuple bh, ValueTuple bh ~ b, Memory.C b) => process (a,b) c -> bh -> process a c proc $># x = CausalClass.applyConstSnd proc $ Class.valueTupleOf x compose :: T a b -> T b c -> T a c compose (Cons nextA startA createIOContextA deleteIOContextA) (Cons nextB startB createIOContextB deleteIOContextB) = Cons (\(ioContextA, ioContextB) a (sa0,sb0) -> do (b,sa1) <- nextA ioContextA a sa0 (c,sb1) <- nextB ioContextB b sb0 return (c, (sa1,sb1))) (\(ioContextA, ioContextB) -> liftM2 (,) (startA ioContextA) (startB ioContextB)) (liftM2 (,) createIOContextA createIOContextB) (\(ca,cb) -> deleteIOContextA ca >> deleteIOContextB cb) first :: (C process) => process b c -> process (b, d) (c, d) first = alter (\(Core next start stop) -> Core (Causal.firstNext next) start stop) instance Cat.Category T where id = map return (.) = flip compose instance Arr.Arrow T where arr f = map (return . f) first = first instance Functor (T a) where fmap = ArrowUtil.map instance Applicative (T a) where pure = ArrowUtil.pure (<*>) = ArrowUtil.apply instance (A.Additive b) => Additive.C (T a b) where zero = pure A.zero negate = mapProc A.neg (+) = zipProcWith A.add (-) = zipProcWith A.sub instance (A.PseudoRing b, A.IntegerConstant b) => Ring.C (T a b) where one = pure A.one fromInteger n = pure (A.fromInteger' n) (*) = zipProcWith A.mul instance (A.Field b, A.RationalConstant b) => Field.C (T a b) where fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x) (/) = zipProcWith A.fdiv instance (A.PseudoRing b, A.Real b, A.IntegerConstant b) => P.Num (T a b) where fromInteger n = pure (A.fromInteger' n) negate = mapProc A.neg (+) = zipProcWith A.add (-) = zipProcWith A.sub (*) = zipProcWith A.mul abs = mapProc A.abs signum = mapProc A.signum instance (A.Field b, A.Real b, A.RationalConstant b) => P.Fractional (T a b) where fromRational x = pure (A.fromRational' x) (/) = zipProcWith A.fdiv {- | You may also use '(+)'. -} mix :: (C process, A.Additive a) => process (a, a) a mix = zipWith Frame.mix {- | You may also use '(*)'. -} envelope :: (C process, A.PseudoRing a) => process (a, a) a envelope = zipWith Frame.amplifyMono envelopeStereo :: (C process, A.PseudoRing a) => process (a, Stereo.T a) (Stereo.T a) envelopeStereo = zipWith Frame.amplifyStereo amplify :: (C process, IsArithmetic a, IsConst a) => a -> process (Value a) (Value a) amplify x = map (Frame.amplifyMono (valueOf x)) amplifyStereo :: (C process, IsArithmetic a, IsConst a) => a -> process (Stereo.T (Value a)) (Stereo.T (Value a)) amplifyStereo x = map (Frame.amplifyStereo (valueOf x)) loopConst :: (C process, Memory.C c) => c -> process (a,c) (b,c) -> process a b loopConst init = alter (\(Core next start stop) -> Core (Causal.loopNext next) (fmap ((,) init) . start) (stop . snd)) {- | Like 'Synthesizer.LLVM.CausalParameterized.loop' but uses zero as initial value and it does not need a zero as Haskell value. -} loopZero :: (C process, A.Additive c, Memory.C c) => process (a,c) (b,c) -> process a b loopZero = loopConst A.zero delay1Zero :: (C process, A.Additive a, Memory.C a) => process a a delay1Zero = loopZero (arr swap) {- | This allows to compute a chain of equal processes efficiently, if all of these processes can be bundled in one vectorial process. Applications are an allpass cascade or an FM operator cascade. The function expects that the vectorial input process works like parallel scalar processes. The different pipeline stages may be controlled by different parameters, but the structure of all pipeline stages must be equal. Our function feeds the input of the pipelined process to the zeroth element of the Vector. The result of processing the i-th element (the i-th channel, so to speak) is fed to the (i+1)-th element. The (n-1)-th element of the vectorial process is emitted as output of the pipelined process. The pipeline necessarily introduces a delay of (n-1) values. For simplification we extend this to n values delay. If you need to combine the resulting signal from the pipeline with another signal in a 'zip'-like way, you may delay that signal with @pipeline id@. The first input values in later stages of the pipeline are initialized with zero. If this is not appropriate for your application, then we may add a more sensible initialization. -} pipeline :: (C process, TypeNum.Positive n, MultiVector.C x, v ~ MultiVector.T n x, a ~ MultiValue.T x, Class.Zero v, Memory.C v) => process v v -> process a a pipeline vectorProcess = loopConst MultiVector.zero $ map (uncurry MultiVector.shiftUp) >>> Arr.second vectorProcess feedbackControlledZero :: (C process, A.Additive c, Memory.C c) => process ((ctrl,a),c) b -> process (ctrl,b) c -> process (ctrl,a) b feedbackControlledZero forth back = loopZero (Causal.feedbackControlledAux forth back) {- In order to let this work we have to give the disable-mmx option somewhere, but where? -} stereoFromVector :: (C process, IsPrimitive a, IsPrimitive b) => process (Value (LLVM.Vector D2 a)) (Value (LLVM.Vector D2 b)) -> process (Stereo.T (Value a)) (Stereo.T (Value b)) stereoFromVector proc = map Frame.stereoFromVector <<< proc <<< map Frame.vectorFromStereo {- insert and extract instructions will be in opposite order, no matter whether we use foldr or foldl and independent from the order of proc and channel in replaceChannel. However, LLVM neglects the order anyway. -} vectorize :: (C process, TypeNum.Positive n, MultiVector.C x, MultiValue.T x ~ a, MultiVector.T n x ~ va, MultiVector.C y, MultiValue.T y ~ b, MultiVector.T n y ~ vb) => process a b -> process va vb vectorize proc = withSize $ \n -> foldl (\acc i -> replaceChannel i proc acc) (arr (const $ Class.undefTuple)) $ List.take (TypeNum.integralFromSingleton n) [0 ..] withSize :: (TypeNum.Positive n, MultiVector.T n a ~ v) => (TypeNum.Singleton n -> f v) -> f v withSize f = f TypeNum.singleton {- | Given a vector process, replace the i-th output by output that is generated by a scalar process from the i-th input. -} replaceChannel :: (C process, TypeNum.Positive n, MultiVector.C x, MultiValue.T x ~ a, MultiVector.T n x ~ va, MultiVector.C y, MultiValue.T y ~ b, MultiVector.T n y ~ vb) => Int -> process a b -> process va vb -> process va vb replaceChannel i channel proc = let li = valueOf $ fromIntegral i in zipWith (MultiVector.insert li) <<< (channel <<< map (MultiVector.extract li)) &&& proc {- | Read the i-th element from each array. -} arrayElement :: (C process, IsFirstClass a, TypeNum.Natural index, TypeNum.Natural dim, index :<: dim) => Proxy index -> process (Value (LLVM.Array dim a)) (Value a) arrayElement i = map (\array -> LLVM.extractvalue array i) {- | Read the i-th element from an aggregate type. -} element :: (C process, IsFirstClass a, LLVM.GetValue agg index, LLVM.ValueType agg index ~ a) => index -> process (Value agg) (Value a) element i = map (\array -> LLVM.extractvalue array i) {- | Compute the phases from phase distortions and frequencies. It's like integrate but with wrap-around performed by @fraction@. For FM synthesis we need also negative phase distortions, thus we use 'A.addToPhase' which supports that. -} osciCore, _osciCore, osciCoreSync :: (C process, Memory.C t, A.Fraction t) => process (t, t) (t) _osciCore = zipWith A.addToPhase <<< Arr.second (mapAccum (\a s -> do b <- A.incPhase a s return (s,b)) (return A.zero)) {- This could be implemented using a generalized frequencyModulation, however, osciCoreSync allows for negative phase differences. -} osciCoreSync = zipWith A.addToPhase <<< Arr.second (mapAccum (\a s -> do b <- A.incPhase a s return (b,b)) (return A.zero)) osciCore = zipWith A.addToPhase <<< Arr.second (loopZero (arr snd &&& zipWith A.incPhase)) osci :: (C process, Memory.C t, A.Fraction t) => (forall r. t -> CodeGenFunction r y) -> process (t, t) y osci wave = map wave <<< osciCore shapeModOsci :: (C process, Memory.C t, A.Fraction t) => (forall r. c -> t -> CodeGenFunction r y) -> process (c, (t, t)) y shapeModOsci wave = zipWith wave <<< Arr.second osciCore alterSignal :: (C process, CausalClass.SignalOf process ~ signal) => (forall context initState exitState. Sig.Core context initState exitState a0 -> Core context initState exitState a1 b1) -> signal a0 -> process a1 b1 alterSignal f = alter (\(Core next start stop) -> f (Sig.Core (\c -> next c ()) start stop)) . CausalClass.fromSignal {- | Feeds a signal into a causal process while holding or skipping signal elements according to the process input. The skip happens after a value is passed from the fed signal. @skip x $* 0@ repeats the first signal value in the output. @skip x $* 1@ feeds the signal to the output as is. @skip x $* 2@ feeds the signal to the output with double speed. -} skip :: (C process, CausalClass.SignalOf process ~ signal, Undefined v, Phi v, Memory.C v) => signal v -> process (Value Word32) v skip = alterSignal (\(Sig.Core next start stop) -> Core (\context n1 (yState0,n0) -> do (y,state1) <- MaybeCont.fromMaybe $ fmap snd $ MaybeCont.fixedLengthLoop n0 yState0 $ next context . snd return (y, ((y,state1),n1))) (fmap (\s -> ((Class.undefTuple, s), A.one)) . start) (\((_y,state),_k) -> stop state)) {- It is quite similar to quantizeLift but the control is the reciprocal. This is especially a problem since we need the fractional part for interpolation. -} frequencyModulation :: (C process, CausalClass.SignalOf process ~ signal, SoV.IntegerConstant a, LLVM.IsFloating a, LLVM.CmpRet a, LLVM.CmpResult a ~ Bool, Memory.FirstClass a, Memory.Stored a ~ am, LLVM.IsSized am, Undefined nodes, Phi nodes, Memory.C nodes) => (forall r. Value a -> nodes -> CodeGenFunction r v) -> signal nodes -> process (Value a) v frequencyModulation ip = alterSignal (\(Sig.Core next start stop) -> Core (\context k yState0 -> do ((nodes2,state2), ss2) <- MaybeCont.fromBool $ C.whileLoop (valueOf True, yState0) (\(cont0, (_, ss0)) -> LLVM.and cont0 =<< A.fcmp LLVM.FPOGE ss0 A.one) (\(_,((_,state0), ss0)) -> MaybeCont.toBool $ liftM2 (,) (next context state0) (MaybeCont.lift $ A.sub ss0 A.one)) MaybeCont.lift $ do y <- ip ss2 nodes2 ss3 <- A.add ss2 k return (y, ((nodes2, state2), ss3))) (fmap (\sa -> ((Class.undefTuple, sa), A.one)) . start) (\((_y01,state),_ss) -> stop state)) {- | Stretch signal in time by a time-varying factor. -} interpolateConstant :: (C process, CausalClass.SignalOf process ~ signal, Memory.C a, Memory.FirstClass b, Memory.Stored b ~ bm, LLVM.IsSized bm, SoV.IntegerConstant b, LLVM.IsFloating b, LLVM.CmpRet b, LLVM.CmpResult b ~ Bool) => signal a -> process (Value b) a interpolateConstant xs = quantizeLift (CausalClass.fromSignal xs) $># () quantizeLift :: (C process, Memory.C b, SoV.IntegerConstant c, LLVM.IsFloating c, LLVM.CmpRet c, LLVM.CmpResult c ~ Bool, Memory.FirstClass c, Memory.Stored c ~ cm, LLVM.IsSized cm) => process a b -> process (Value c, a) b quantizeLift = alter (\(Core next start stop) -> Core (\context (k, a0) yState0 -> do (yState1, frac1) <- MaybeCont.fromBool $ C.whileLoop (LLVM.valueOf True, yState0) (\(cont1, (_, frac0)) -> LLVM.and cont1 =<< A.fcmp LLVM.FPOLE frac0 A.zero) (\(_,((_,state01), frac0)) -> MaybeCont.toBool $ liftM2 (,) (next context a0 state01) (MaybeCont.lift $ A.add frac0 k)) frac2 <- MaybeCont.lift $ A.sub frac1 A.one return (fst yState1, (yState1, frac2))) {- using this initialization code we would not need undefined values (do sa <- start (a,_) <- next sa return (sa, a, A.zero)) -} (\p -> do s <- start p return ((Class.undefTuple, s), A.zero)) (\((_, s), _) -> stop s)) applyStorable :: (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T valueA valueB -> SV.Vector a -> SV.Vector b applyStorable (Cons next start createIOContext deleteIOContext) as = Unsafe.performIO $ bracket createIOContext deleteIOContext $ \ ioContext -> SVB.withStartPtr as $ \ aPtr len -> SVB.createAndTrim len $ \ bPtr -> do fill <- simpleFunction $ createNamedFunction ExternalLinkage "fillprocessblock" $ \ size alPtr blPtr -> do s <- start ioContext (pos,_) <- MaybeCont.arrayLoop2 size alPtr blPtr s $ \ aPtri bPtri s0 -> do a <- MaybeCont.lift $ Memory.load aPtri (b,s1) <- next ioContext a s0 MaybeCont.lift $ Memory.store b bPtri return s1 ret (pos :: Value Word32) fmap (fromIntegral :: Word32 -> Int) $ fill (fromIntegral len) (Memory.castStorablePtr aPtr) (Memory.castStorablePtr bPtr) foreign import ccall safe "dynamic" derefChunkPtr :: Exec.Importer (Ptr stateStruct -> Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32) compileChunky :: (Memory.C aValue, Memory.Struct aValue ~ aStruct, Memory.C bValue, Memory.Struct bValue ~ bStruct, Memory.C state, Memory.Struct state ~ stateStruct) => (forall r z. (Phi z) => aValue -> state -> MaybeCont.T r z (bValue, state)) -> (forall r. CodeGenFunction r state) -> IO (FunPtr (IO (Ptr stateStruct)), FunPtr (Ptr stateStruct -> IO ()), FunPtr (Ptr stateStruct -> Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32)) compileChunky next start = Exec.compileModule $ liftM3 (,,) (createNamedFunction ExternalLinkage "startprocess" $ do pptr <- LLVM.malloc flip Memory.store pptr =<< start ret pptr) (createNamedFunction ExternalLinkage "stopprocess" $ \ pptr -> LLVM.free pptr >> ret ()) (createNamedFunction ExternalLinkage "fillprocess" $ \ sptr loopLen aPtr bPtr -> do sInit <- Memory.load sptr (pos,sExit) <- MaybeCont.arrayLoop2 loopLen aPtr bPtr sInit $ \ aPtri bPtri s0 -> do a <- MaybeCont.lift $ Memory.load aPtri (b,s1) <- next a s0 MaybeCont.lift $ Memory.store b bPtri return s1 Memory.store (Maybe.fromJust sExit) sptr ret (pos :: Value Word32)) {-# DEPRECATED runStorableChunky "this function will not work when the process itself depends on a lazy storable vector" #-} {- | This function will not work as expected, since feeding a lazy storable vector to the causal process means that createIOContext creates a StablePtr to an IORef refering to a chunk list. The IORef will be created once for all uses of the generated function of type @(SVL.Vector a -> SVL.Vector b)@. This means that the pointer into the chunks list will conflict. An alternative would be to create the StablePtr in a foreign function that calls back to Haskell. But this way is disallowed for foreign finalizers. -} runStorableChunky :: (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T valueA valueB -> IO (SVL.Vector a -> SVL.Vector b) runStorableChunky (Cons next start createIOContext deleteIOContext) = do ioContext <- createIOContext (startFunc, stopFunc, fill) <- compileChunky (next ioContext) (start ioContext) {- This is a dummy pointer, that we need for correct finalization. Concerning the live time the FunPtr 'fill' also has the live time that we are after, but it is unsafe to treat a FunPtr as a Ptr or ForeignPtr. -} ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False return $ \sig -> SVL.fromChunks $ Unsafe.performIO $ do statePtr <- ForeignPtr.newInit stopFunc startFunc 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 :: Word32 -> Int) . derefChunkPtr fill sptr (fromIntegral size) (Memory.castStorablePtr aPtr) . Memory.castStorablePtr touchForeignPtr ioContextPtr (if SV.length v > 0 then fmap (v:) else id) $ (if SV.length v < size then return [] else go xs) go (SVL.chunks sig) applyStorableChunky :: (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA, Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) => T valueA valueB -> SVL.Vector a -> SVL.Vector b applyStorableChunky (Cons next start createIOContext deleteIOContext) sig = SVL.fromChunks $ Unsafe.performIO $ do ioContext <- createIOContext (startFunc, stopFunc, fill) <- compileChunky (next ioContext) (start ioContext) statePtr <- ForeignPtr.newInit stopFunc startFunc {- This is a dummy pointer, that we need for correct finalization. Concerning the live time the FunPtr 'fill' also has the live time that we are after, but it is unsafe to treat a FunPtr as a Ptr or ForeignPtr. -} ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False 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 :: Word32 -> Int) . derefChunkPtr fill sptr (fromIntegral size) (Memory.castStorablePtr aPtr) . Memory.castStorablePtr touchForeignPtr ioContextPtr (if SV.length v > 0 then fmap (v:) else id) $ (if SV.length v < size then return [] else go xs) go (SVL.chunks sig)