synthesizer-llvm-0.7: src/Synthesizer/LLVM/Causal/Process.hs
{-# 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)