{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
module Synthesizer.LLVM.Storable.Process (
makeArranger,
continuePacked,
) where
import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial
import qualified Synthesizer.LLVM.Storable.Signal as SigStL
import qualified Synthesizer.CausalIO.Process as PIO
import qualified Synthesizer.Generic.Cut as CutG
import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Relative.TimeTime as EventListTT
import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Data.EventList.Absolute.TimeBody as AbsEventList
import qualified LLVM.Extra.Multi.Value.Storable as Storable
import qualified LLVM.Extra.Multi.Value as MultiValue
import qualified LLVM.Extra.Arithmetic as A
import qualified Type.Data.Num.Decimal as TypeNum
import qualified Control.Arrow as Arr
import qualified Data.Foldable as Fold
import Foreign.Marshal.Array (advancePtr)
import qualified System.Unsafe as Unsafe
import qualified Number.NonNegative as NonNeg
import NumericPrelude.Numeric
import NumericPrelude.Base
makeArranger ::
(Arr.Arrow arrow, Storable.C a, MultiValue.Additive a) =>
IO (arrow
(EventListTT.T NonNeg.Int (SV.Vector a))
(SV.Vector a))
makeArranger :: forall (arrow :: * -> * -> *) a.
(Arrow arrow, C a, Additive a) =>
IO (arrow (T Int (Vector a)) (Vector a))
makeArranger = do
Word -> Ptr a -> Ptr a -> IO ()
mixer <- (T a -> T a -> CodeGenFunction () (T a))
-> IO (Word -> Ptr a -> Ptr a -> IO ())
forall a value.
(C a, T a ~ value) =>
(value -> value -> CodeGenFunction () value)
-> IO (Word -> Ptr a -> Ptr a -> IO ())
SigStL.makeMixer T a -> T a -> CodeGenFunction () (T a)
forall a r. Additive a => a -> a -> CodeGenFunction r a
forall r. T a -> T a -> CodeGenFunction r (T a)
A.add
Word -> Ptr a -> IO ()
fill <- T a -> IO (Word -> Ptr a -> IO ())
forall a value.
(C a, T a ~ value) =>
value -> IO (Word -> Ptr a -> IO ())
SigStL.fillBuffer T a
forall a. Additive a => a
A.zero
arrow (T Int (Vector a)) (Vector a)
-> IO (arrow (T Int (Vector a)) (Vector a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (arrow (T Int (Vector a)) (Vector a)
-> IO (arrow (T Int (Vector a)) (Vector a)))
-> arrow (T Int (Vector a)) (Vector a)
-> IO (arrow (T Int (Vector a)) (Vector a))
forall a b. (a -> b) -> a -> b
$ (T Int (Vector a) -> Vector a)
-> arrow (T Int (Vector a)) (Vector a)
forall b c. (b -> c) -> arrow b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
Arr.arr ((T Int (Vector a) -> Vector a)
-> arrow (T Int (Vector a)) (Vector a))
-> (T Int (Vector a) -> Vector a)
-> arrow (T Int (Vector a)) (Vector a)
forall a b. (a -> b) -> a -> b
$ \ T Int (Vector a)
now ->
let
sznn :: Int
sznn = T Int (Vector a) -> Int
forall time body. C time => T time body -> time
EventListTT.duration T Int (Vector a)
now
sz :: Int
sz = Int -> Int
forall a. T a -> a
NonNeg.toNumber Int
sznn
xs :: [(Int, Vector a)]
xs =
T Int (Vector a) -> [(Int, Vector a)]
forall a b. T a b -> [(a, b)]
AbsEventList.toPairList (T Int (Vector a) -> [(Int, Vector a)])
-> T Int (Vector a) -> [(Int, Vector a)]
forall a b. (a -> b) -> a -> b
$
(Int -> Int) -> T Int (Vector a) -> T Int (Vector a)
forall time0 time1 body.
(time0 -> time1) -> T time0 body -> T time1 body
AbsEventList.mapTime Int -> Int
forall a. T a -> a
NonNeg.toNumber (T Int (Vector a) -> T Int (Vector a))
-> T Int (Vector a) -> T Int (Vector a)
forall a b. (a -> b) -> a -> b
$
Int -> T Int (Vector a) -> T Int (Vector a)
forall time body. Num time => time -> T time body -> T time body
EventList.toAbsoluteEventList Int
0 (T Int (Vector a) -> T Int (Vector a))
-> T Int (Vector a) -> T Int (Vector a)
forall a b. (a -> b) -> a -> b
$
(T Int (Vector a) -> Int -> T Int (Vector a))
-> T Int (Vector a) -> T Int (Vector a)
forall time body a. (T time body -> time -> a) -> T time body -> a
EventListTM.switchTimeR T Int (Vector a) -> Int -> T Int (Vector a)
forall a b. a -> b -> a
const T Int (Vector a)
now
in IO (Vector a) -> Vector a
forall a. IO a -> a
Unsafe.performIO (IO (Vector a) -> Vector a) -> IO (Vector a) -> Vector a
forall a b. (a -> b) -> a -> b
$
Int -> (Ptr a -> IO Int) -> IO (Vector a)
forall a. Storable a => Int -> (Ptr a -> IO Int) -> IO (Vector a)
SVB.createAndTrim Int
sz ((Ptr a -> IO Int) -> IO (Vector a))
-> (Ptr a -> IO Int) -> IO (Vector a)
forall a b. (a -> b) -> a -> b
$ \Ptr a
dstPtr -> do
Word -> Ptr a -> IO ()
fill (Int -> Word
forall a b. (C a, C b) => a -> b
fromIntegral Int
sz) Ptr a
dstPtr
[(Int, Vector a)] -> ((Int, Vector a) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Fold.forM_ [(Int, Vector a)]
xs (((Int, Vector a) -> IO ()) -> IO ())
-> ((Int, Vector a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
i,Vector a
s) ->
Vector a -> (Ptr a -> Int -> IO ()) -> IO ()
forall a b.
Storable a =>
Vector a -> (Ptr a -> Int -> IO b) -> IO b
SVB.withStartPtr Vector a
s ((Ptr a -> Int -> IO ()) -> IO ())
-> (Ptr a -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
srcPtr Int
len ->
let llen :: Word
llen =
if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
szInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
i
then Int -> Word
forall a b. (C a, C b) => a -> b
fromIntegral Int
len
else [Char] -> Word
forall a. HasCallStack => [Char] -> a
error [Char]
"Process.arrange: chunk larger that event list"
in Word -> Ptr a -> Ptr a -> IO ()
mixer Word
llen Ptr a
srcPtr (Ptr a -> Int -> Ptr a
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr a
dstPtr Int
i)
Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
sz
continuePacked ::
(CutG.Transform a, Storable.Vector b, TypeNum.Positive n) =>
PIO.T a (SV.Vector (Serial.T n b)) ->
(b -> PIO.T a (SV.Vector (Serial.T n b))) ->
PIO.T a (SV.Vector (Serial.T n b))
continuePacked :: forall a b n.
(Transform a, Vector b, Positive n) =>
T a (Vector (T n b))
-> (b -> T a (Vector (T n b))) -> T a (Vector (T n b))
continuePacked T a (Vector (T n b))
proc0 b -> T a (Vector (T n b))
proc1 =
T a (Vector (T n b))
-> (Vector (T n b) -> T a (Vector (T n b))) -> T a (Vector (T n b))
forall a b.
(Transform a, Transform b) =>
T a b -> (b -> T a b) -> T a b
PIO.continueChunk T a (Vector (T n b))
proc0
(b -> T a (Vector (T n b))
proc1 (b -> T a (Vector (T n b)))
-> (Vector (T n b) -> b) -> Vector (T n b) -> T a (Vector (T n b))
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
Arr.<<^ Vector b -> b
forall a. Storable a => Vector a -> a
SV.last (Vector b -> b)
-> (Vector (T n b) -> Vector b) -> Vector (T n b) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (T n b) -> Vector b
forall n a. (Positive n, Vector a) => Vector (T n a) -> Vector a
SigStL.unpackStrict)