module Synthesizer.LLVM.CausalParameterized.Process (
T, 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,
fromInitializedModifier,
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,
reverbSimple,
reverb,
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, reverbParams, )
import Synthesizer.LLVM.Causal.Process (loopZero, mix, )
import qualified Synthesizer.LLVM.Causal.ProcessPrivate as CausalPriv
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 qualified Synthesizer.LLVM.CausalParameterized.RingBuffer as RingBuffer
import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigPPriv
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Simple.SignalPrivate as SigPriv
import qualified Synthesizer.LLVM.Simple.Value as Value
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 Synthesizer.LLVM.ForeignPtr as ForeignPtr
import Synthesizer.LLVM.Parameter (($#), )
import qualified Synthesizer.Causal.Class as CausalClass
import qualified Synthesizer.Generic.Cut as Cut
import qualified Synthesizer.Plain.Modifier as Modifier
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB
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.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, )
import qualified Type.Data.Num.Decimal as TypeNum
import Type.Data.Num.Decimal (D1, )
import qualified Control.Category as Cat
import Control.Monad.Trans.State (runState, )
import Control.Arrow (arr, first, second, (<<<), (<<^), (>>>), (&&&), )
import Control.Monad (liftM, when, )
import Control.Applicative (liftA2, liftA3, pure, (<*>), )
import Control.Functor.HT (void, unzip, )
import Control.Exception (bracket, )
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, )
import qualified Synthesizer.LLVM.Alloc as Alloc
import qualified Foreign.Marshal.Utils as AllocUtil
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 qualified System.Unsafe as Unsafe
import qualified Synthesizer.LLVM.Debug.Storable as DebugSt
import qualified Synthesizer.LLVM.Debug.Counter as DebugCnt
import qualified Algebra.Transcendental as Trans
import NumericPrelude.Numeric
import NumericPrelude.Base hiding
(and, iterate, map, unzip, zip, zipWith, take, takeWhile, sequence_, )
infixl 0 $<, $>, $*
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
($*) :: 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 alloca stop next create delete) =
Cons start alloca 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 ())
fromInitializedModifier ::
(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,
Value.Flatten ih, Value.Registers ih ~ il, Memory.C il,
Storable i, MakeValueTuple i, ValueTuple i ~ il) =>
Modifier.Initialized sh ih ch ah bh -> Param.T p i -> T p (cl,al) bl
fromInitializedModifier (Modifier.Initialized initF step) =
mapAccum
(\() (c,a) s ->
Value.flatten $
runState
(step (Value.unfold c) (Value.unfold a))
(Value.unfold s))
(Value.flattenFunction initF)
(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
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 alloca start stop createIOContext deleteIOContext -> Cons
(replicateControlledNext next stop)
alloca
(replicateControlledStart start)
(replicateControlledStop stop)
(\p ->
replicateControlledCreate $
mapM
(\a -> createIOContext (p,a))
(Param.get ps p))
(replicateControlledDelete deleteIOContext)
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)
stereoFromMono ::
(Phi a, Phi b, Undefined b) =>
T p a b -> T p (Stereo.T a) (Stereo.T b)
stereoFromMono
(Cons next alloca start stop createIOContext deleteIOContext) = Cons
(stereoNext stop next)
alloca
(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 alloca start stop createIOContext deleteIOContext -> Cons
(stereoNext stop next)
alloca
(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 -> local -> a -> s -> MaybeCont.T r z (b, s)) ->
Stereo.T context ->
local ->
Stereo.T a ->
Stereo.T s ->
MaybeCont.T r c (Stereo.T b, Stereo.T s)
stereoNext stop next context local a s0 = MaybeCont.fromMaybe $ do
mbs1 <-
twiceStereo
(MaybeCont.toMaybe . uncurry3 (flip next local))
(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))
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
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 ::
(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
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 ::
(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
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)
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)
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
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)))
reverbSimple ::
(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)
reverbSimple rnd num gainRange timeRange =
mapSimple (A.mul (A.fromRational' $ recip $ fromIntegral num)) <<<
(foldl (+) zero $
List.map (\(g,t) -> comb $# g $# t) $
reverbParams rnd num gainRange timeRange)
reverb ::
(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)
reverb 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))
_skipVolatile ::
(Causal.C process, CausalClass.SignalOf process ~ signal) =>
signal v -> process (Value Word32) v
_skipVolatile =
CausalPriv.alterSignal
(\(SigPriv.Core next start stop) -> CausalPriv.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 ::
(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 ::
(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
(SigPPriv.Cons next alloca start stop createIOContext deleteIOContext) = Cons
(\(creator, eraser) (local, (param, xPtr)) mx mcsio0 -> MaybeCont.lift $ do
mcsio1 <-
Maybe.run mx
(return mcsio0)
(\x ->
stopAndDelete eraser stop mcsio0
>>
do
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 local s1
return (fmap (fst.snd.fst) mcasio2, fmap (mapFst (mapSnd snd)) mcasio2))
(liftA2 (,) alloca $ liftA2 (,) LLVM.alloca LLVM.alloca)
(\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)
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 alloca start stop createIOContext deleteIOContext) = do
fill <-
Exec.compileModule $
Exec.createFunction derefFillPtr "fillprocessblock" $
\paramPtr size alPtr blPtr -> do
param <- Memory.load paramPtr
(c,s) <- start param
local <- alloca
(pos,msExit) <- MaybeCont.arrayLoop2 size alPtr blPtr s $
\ aPtri bPtri s0 -> do
a <- MaybeCont.lift $ Memory.load aPtri
(b,s1) <- next c local a s0
MaybeCont.lift $ Memory.store b bPtri
return s1
Maybe.for msExit $ stop c
ret pos
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.castTuplePtr paramPtr)
(fromIntegral len)
(Memory.castTuplePtr aPtr)
(Memory.castTuplePtr 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 -> local ->
valueA -> state ->
MaybeCont.T r z (valueB, state)) ->
(forall r. CodeGenFunction r local) ->
(forall r.
parameters ->
CodeGenFunction r (context, state)) ->
(forall r.
context -> state ->
CodeGenFunction r ()) ->
IO (Ptr paramStruct -> IO (Ptr contextStateStruct),
Exec.Finalizer contextStateStruct,
Ptr contextStateStruct -> Word32 ->
Ptr structA -> Ptr structB -> IO Word32)
compileChunky next alloca start stop =
Exec.compileModule $
liftA3 (,,)
(Exec.createFunction derefStartPtr "startprocess" $
\paramPtr -> do
pptr <- LLVM.malloc
flip Memory.store pptr . mapSnd Maybe.just =<< start =<< Memory.load paramPtr
ret pptr)
(Exec.createFinalizer derefStopPtr "stopprocess" $
\ contextStatePtr -> do
(c,ms) <- Memory.load contextStatePtr
Maybe.for ms $ stop c
LLVM.free contextStatePtr
ret ())
(Exec.createFunction derefChunkPtr "fillprocess" $
\ contextStatePtr loopLen aPtr bPtr -> do
(param, msInit) <- Memory.load contextStatePtr
local <- alloca
(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 local a s0
MaybeCont.lift $ Memory.store b bPtri
return s1
sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())
Memory.store msExit sptr
ret pos)
foreign import ccall safe "dynamic" derefStartPtr ::
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 -> local ->
valueA -> state ->
MaybeCont.T r z (valueB, state)) ->
(forall r. CodeGenFunction r local) ->
(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 (Ptr paramStruct -> IO (Ptr contextStateStruct),
Ptr contextStateStruct -> IO (),
Ptr contextStateStruct -> Word32 ->
Ptr paramStructIn -> Ptr paramStructOut -> IO Word32)
compilePlugged nextIn startIn next alloca start stop nextOut startOut =
Exec.compileModule $
liftA3 (,,)
(Exec.createFunction derefStartPtr "startprocess" $
\paramPtr -> do
pptr <- LLVM.malloc
flip Memory.store pptr . mapSnd Maybe.just =<< start =<< Memory.load paramPtr
ret pptr)
(Exec.createFunction derefStopPtr "stopprocess" $
\ contextStatePtr -> do
(c,ms) <- Memory.load contextStatePtr
Maybe.for ms $ stop c
LLVM.free contextStatePtr
ret ())
(Exec.createFunction derefChunkPtr "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
local <- alloca
(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 local 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)
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
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 alloca start stop createIOContext deleteIOContext) = do
(startFunc, stopFunc, fill) <- compileChunky next alloca 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
ioContextPtr <- ForeignPtr.newAux (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 .
fill sptr
(fromIntegral size)
(Memory.castTuplePtr aPtr) .
Memory.castTuplePtr
touchForeignPtr ioContextPtr
(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)
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 alloca start stop createIOContext deleteIOContext)
(POut.Cons nextOut startOut createOut deleteOut) = do
(startFunc, stopFunc, fill) <-
compilePlugged nextIn startIn next alloca 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 ->
fill paramPtr
(fromIntegral maximumSize)
(Memory.castTuplePtr inptr)
(Memory.castTuplePtr 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
(startFunc . Memory.castTuplePtr)
return (ioContext, contextStatePtr))
(\(ioContext, contextStatePtr) -> do
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