{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{- |
Functions on storable vectors that are implemented using LLVM.
-}
module Synthesizer.LLVM.Storable.Signal (
   unpackStrict, unpack,
   unpackStereoStrict, unpackStereo,
   makeReversePackedStrict, makeReversePacked,
   continue, continuePacked, continuePackedGeneric,
   fillBuffer, makeMixer,
   makeArranger,
   ) where

import qualified Synthesizer.LLVM.Frame.SerialVector.Code as Serial

import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoVector
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo

import qualified Data.StorableVector.Lazy as SVL
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.TimeMixed as EventListTM
import qualified Data.EventList.Absolute.TimeBody  as AbsEventList
import qualified Number.NonNegative as NonNeg

import qualified LLVM.DSL.Execution as Exec
import qualified LLVM.Extra.Multi.Value.Storable as Storable
import qualified LLVM.Extra.Multi.Value as MultiValue
import qualified LLVM.Core as LLVM

import qualified Type.Data.Num.Decimal as TypeNum

import Control.Monad.HT (void)

import Foreign.Marshal.Array (advancePtr)
import Foreign.ForeignPtr (castForeignPtr)
import Foreign.Storable (Storable)
import Foreign.Ptr (Ptr)

import qualified System.Unsafe as Unsafe


{- |
This function needs only constant time
in contrast to 'Synthesizer.LLVM.Parameterized.SignalPacked.unpack'.

We cannot provide a 'pack' function
since the array size may not line up.
It would also need copying since the source data may not be aligned properly.
-}
unpackChunk ::
   (Storable.C a, TypeNum.Positive n) =>
   SV.Vector (Serial.T n a) -> SV.Vector a
unpackChunk :: forall a n. (C a, Positive n) => Vector (T n a) -> Vector a
unpackChunk Vector (T n a)
v =
   let getDim ::
          (TypeNum.Positive n) =>
          SV.Vector (Serial.T n a) -> TypeNum.Singleton n -> Int
       getDim :: forall n a. Positive n => Vector (T n a) -> Singleton n -> Int
getDim Vector (T n a)
_ = Singleton n -> Int
forall n a. (Integer n, Num a) => Singleton n -> a
TypeNum.integralFromSingleton
       d :: Int
d = Vector (T n a) -> Singleton n -> Int
forall n a. Positive n => Vector (T n a) -> Singleton n -> Int
getDim Vector (T n a)
v Singleton n
forall x. Integer x => Singleton x
TypeNum.singleton
       (ForeignPtr (T n a)
fptr,Int
s,Int
l) = Vector (T n a) -> (ForeignPtr (T n a), Int, Int)
forall a. Vector a -> (ForeignPtr a, Int, Int)
SVB.toForeignPtr Vector (T n a)
v
   in  ForeignPtr a -> Int -> Int -> Vector a
forall a. ForeignPtr a -> Int -> Int -> Vector a
SVB.SV (ForeignPtr (T n a) -> ForeignPtr a
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr (T n a)
fptr) (Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
d) (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
d)


unpackStrict ::
   (TypeNum.Positive n, Storable.Vector a) =>
   SV.Vector (Serial.T n a) -> SV.Vector a
unpackStrict :: forall n a. (Positive n, Vector a) => Vector (T n a) -> Vector a
unpackStrict = Vector (T n a) -> Vector a
forall a n. (C a, Positive n) => Vector (T n a) -> Vector a
unpackChunk

unpack ::
   (TypeNum.Positive n, Storable.Vector a) =>
   SVL.Vector (Serial.T n a) -> SVL.Vector a
unpack :: forall n a. (Positive n, Vector a) => Vector (T n a) -> Vector a
unpack = [Vector a] -> Vector a
forall a. Storable a => [Vector a] -> Vector a
SVL.fromChunks ([Vector a] -> Vector a)
-> (Vector (T n a) -> [Vector a]) -> Vector (T n a) -> Vector a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector (T n a) -> Vector a) -> [Vector (T n a)] -> [Vector a]
forall a b. (a -> b) -> [a] -> [b]
map Vector (T n a) -> Vector a
forall a n. (C a, Positive n) => Vector (T n a) -> Vector a
unpackChunk ([Vector (T n a)] -> [Vector a])
-> (Vector (T n a) -> [Vector (T n a)])
-> Vector (T n a)
-> [Vector a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (T n a) -> [Vector (T n a)]
forall a. Vector a -> [Vector a]
SVL.chunks


unpackStereoStrict ::
   (TypeNum.Positive n, Storable.C a) =>
   SV.Vector (StereoVector.T n a) -> SV.Vector (Stereo.T a)
unpackStereoStrict :: forall n a. (Positive n, C a) => Vector (T n a) -> Vector (T a)
unpackStereoStrict Vector (T n a)
v =
   let getDim ::
          (TypeNum.Positive n) =>
          SV.Vector (StereoVector.T n a) -> TypeNum.Singleton n -> Int
       getDim :: forall n a. Positive n => Vector (T n a) -> Singleton n -> Int
getDim Vector (T n a)
_ = Singleton n -> Int
forall n a. (Integer n, Num a) => Singleton n -> a
TypeNum.integralFromSingleton
       d :: Int
d = Vector (T n a) -> Singleton n -> Int
forall n a. Positive n => Vector (T n a) -> Singleton n -> Int
getDim Vector (T n a)
v Singleton n
forall x. Integer x => Singleton x
TypeNum.singleton
       (ForeignPtr (T n a)
fptr,Int
s,Int
l) = Vector (T n a) -> (ForeignPtr (T n a), Int, Int)
forall a. Vector a -> (ForeignPtr a, Int, Int)
SVB.toForeignPtr Vector (T n a)
v
   in  ForeignPtr (T a) -> Int -> Int -> Vector (T a)
forall a. ForeignPtr a -> Int -> Int -> Vector a
SVB.SV (ForeignPtr (T n a) -> ForeignPtr (T a)
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr (T n a)
fptr) (Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
d) (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
d)

unpackStereo ::
   (TypeNum.Positive n, Storable.C a) =>
   SVL.Vector (StereoVector.T n a) -> SVL.Vector (Stereo.T a)
unpackStereo :: forall n a. (Positive n, C a) => Vector (T n a) -> Vector (T a)
unpackStereo =
   [Vector (T a)] -> Vector (T a)
forall a. Storable a => [Vector a] -> Vector a
SVL.fromChunks ([Vector (T a)] -> Vector (T a))
-> (Vector (T n a) -> [Vector (T a)])
-> Vector (T n a)
-> Vector (T a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector (T n a) -> Vector (T a))
-> [Vector (T n a)] -> [Vector (T a)]
forall a b. (a -> b) -> [a] -> [b]
map Vector (T n a) -> Vector (T a)
forall n a. (Positive n, C a) => Vector (T n a) -> Vector (T a)
unpackStereoStrict ([Vector (T n a)] -> [Vector (T a)])
-> (Vector (T n a) -> [Vector (T n a)])
-> Vector (T n a)
-> [Vector (T a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (T n a) -> [Vector (T n a)]
forall a. Vector a -> [Vector a]
SVL.chunks


makeReverser ::
   (Storable.C a, MultiValue.T a ~ value) =>
   (value -> LLVM.CodeGenFunction () value) ->
   IO (Word -> Ptr a -> Ptr a -> IO ())
makeReverser :: forall a value.
(C a, T a ~ value) =>
(value -> CodeGenFunction () value)
-> IO (Word -> Ptr a -> Ptr a -> IO ())
makeReverser value -> CodeGenFunction () value
rev =
   String
-> Exec (Word -> Ptr a -> Ptr a -> IO ())
-> IO (Word -> Ptr a -> Ptr a -> IO ())
forall funcs. String -> Exec funcs -> IO funcs
Exec.compile String
"reverse" (Exec (Word -> Ptr a -> Ptr a -> IO ())
 -> IO (Word -> Ptr a -> Ptr a -> IO ()))
-> Exec (Word -> Ptr a -> Ptr a -> IO ())
-> IO (Word -> Ptr a -> Ptr a -> IO ())
forall a b. (a -> b) -> a -> b
$
   Importer (Word -> Ptr a -> Ptr a -> IO ())
-> String
-> CodeGen (Word -> Ptr a -> Ptr a -> IO ())
-> Exec (Word -> Ptr a -> Ptr a -> IO ())
forall f.
(ExecutionFunction f, C f) =>
Importer f -> String -> CodeGen f -> Exec f
Exec.createFunction Importer (Word -> Ptr a -> Ptr a -> IO ())
forall a. Importer (Word -> Ptr a -> Ptr a -> IO ())
derefMixPtr String
"reverse" (CodeGen (Word -> Ptr a -> Ptr a -> IO ())
 -> Exec (Word -> Ptr a -> Ptr a -> IO ()))
-> CodeGen (Word -> Ptr a -> Ptr a -> IO ())
-> Exec (Word -> Ptr a -> Ptr a -> IO ())
forall a b. (a -> b) -> a -> b
$ \ Value Word
size Value (Ptr a)
ptrA Value (Ptr a)
ptrB -> do
      Value Int
sizeInt <- Value Word -> CodeGenFunction () (Value Int)
forall (value :: * -> *) a b r.
(ValueCons value, IsSized a, IsSized b, SizeOf a ~ SizeOf b) =>
value a -> CodeGenFunction r (value b)
LLVM.bitcast Value Word
size
      Value (Ptr a)
ptrAEnd <- Value Int -> Value (Ptr a) -> CodeGenFunction () (Value (Ptr a))
forall a ptr r.
(Storable a, Value (Ptr a) ~ ptr) =>
Value Int -> ptr -> CodeGenFunction r ptr
Storable.advancePtr Value Int
sizeInt Value (Ptr a)
ptrA
      CodeGenFunction () (Value (Ptr a)) -> CodeGenFunction () ()
forall (m :: * -> *) a. Monad m => m a -> m ()
void (CodeGenFunction () (Value (Ptr a)) -> CodeGenFunction () ())
-> CodeGenFunction () (Value (Ptr a)) -> CodeGenFunction () ()
forall a b. (a -> b) -> a -> b
$ Value Word
-> Value (Ptr a)
-> Value (Ptr a)
-> (Value (Ptr a)
    -> Value (Ptr a) -> CodeGenFunction () (Value (Ptr a)))
-> CodeGenFunction () (Value (Ptr a))
forall s i a ptrA r.
(Phi s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i,
 Storable a, Value (Ptr a) ~ ptrA) =>
Value i
-> ptrA
-> s
-> (ptrA -> s -> CodeGenFunction r s)
-> CodeGenFunction r s
Storable.arrayLoop Value Word
size Value (Ptr a)
ptrB Value (Ptr a)
ptrAEnd ((Value (Ptr a)
  -> Value (Ptr a) -> CodeGenFunction () (Value (Ptr a)))
 -> CodeGenFunction () (Value (Ptr a)))
-> (Value (Ptr a)
    -> Value (Ptr a) -> CodeGenFunction () (Value (Ptr a)))
-> CodeGenFunction () (Value (Ptr a))
forall a b. (a -> b) -> a -> b
$ \ Value (Ptr a)
ptrBi Value (Ptr a)
ptrAj0 -> do
         Value (Ptr a)
ptrAj1 <- Value (Ptr a) -> CodeGenFunction () (Value (Ptr a))
forall a ptr r.
(Storable a, Value (Ptr a) ~ ptr) =>
ptr -> CodeGenFunction r ptr
Storable.decrementPtr Value (Ptr a)
ptrAj0
         (T a -> Value (Ptr a) -> CodeGenFunction () ())
-> Value (Ptr a) -> T a -> CodeGenFunction () ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip T a -> Value (Ptr a) -> CodeGenFunction () ()
forall r. T a -> Value (Ptr a) -> CodeGenFunction r ()
forall a r. C a => T a -> Value (Ptr a) -> CodeGenFunction r ()
Storable.store Value (Ptr a)
ptrBi
            (T a -> CodeGenFunction () ())
-> CodeGenFunction () (T a) -> CodeGenFunction () ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< value -> CodeGenFunction () value
value -> CodeGenFunction () (T a)
rev
            (value -> CodeGenFunction () (T a))
-> CodeGenFunction () value -> CodeGenFunction () (T a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value (Ptr a) -> CodeGenFunction () (T a)
forall a r. C a => Value (Ptr a) -> CodeGenFunction r (T a)
forall r. Value (Ptr a) -> CodeGenFunction r (T a)
Storable.load Value (Ptr a)
ptrAj1
         Value (Ptr a) -> CodeGenFunction () (Value (Ptr a))
forall a. a -> CodeGenFunction () a
forall (m :: * -> *) a. Monad m => a -> m a
return Value (Ptr a)
ptrAj1

makeReversePackedStrict ::
   (TypeNum.Positive n, Storable.Vector a, v ~ Serial.T n a) =>
   IO (SV.Vector v -> SV.Vector v)
makeReversePackedStrict :: forall n a v.
(Positive n, Vector a, v ~ T n a) =>
IO (Vector v -> Vector v)
makeReversePackedStrict = do
   Word -> Ptr v -> Ptr v -> IO ()
rev <- (Value n a -> CodeGenFunction () (Value n a))
-> IO (Word -> Ptr v -> Ptr v -> IO ())
forall a value.
(C a, T a ~ value) =>
(value -> CodeGenFunction () value)
-> IO (Word -> Ptr a -> Ptr a -> IO ())
makeReverser Value n a -> CodeGenFunction () (Value n a)
forall n a r.
(Positive n, C a) =>
Value n a -> CodeGenFunction r (Value n a)
Serial.reverse
   (Vector v -> Vector v) -> IO (Vector v -> Vector v)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Vector v -> Vector v) -> IO (Vector v -> Vector v))
-> (Vector v -> Vector v) -> IO (Vector v -> Vector v)
forall a b. (a -> b) -> a -> b
$ \Vector v
v ->
      IO (Vector v) -> Vector v
forall a. IO a -> a
Unsafe.performIO (IO (Vector v) -> Vector v) -> IO (Vector v) -> Vector v
forall a b. (a -> b) -> a -> b
$
      Vector v -> (Ptr v -> Int -> IO (Vector v)) -> IO (Vector v)
forall a b.
Storable a =>
Vector a -> (Ptr a -> Int -> IO b) -> IO b
SVB.withStartPtr Vector v
v ((Ptr v -> Int -> IO (Vector v)) -> IO (Vector v))
-> (Ptr v -> Int -> IO (Vector v)) -> IO (Vector v)
forall a b. (a -> b) -> a -> b
$ \Ptr v
ptrA Int
len ->
      Int -> (Ptr v -> IO ()) -> IO (Vector v)
forall a. Storable a => Int -> (Ptr a -> IO ()) -> IO (Vector a)
SVB.create Int
len ((Ptr v -> IO ()) -> IO (Vector v))
-> (Ptr v -> IO ()) -> IO (Vector v)
forall a b. (a -> b) -> a -> b
$ \Ptr v
ptrB ->
      Word -> Ptr v -> Ptr v -> IO ()
rev (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) Ptr v
ptrA Ptr v
ptrB

makeReversePacked ::
   (TypeNum.Positive n, Storable.Vector a, v ~ Serial.T n a) =>
   IO (SVL.Vector v -> SVL.Vector v)
makeReversePacked :: forall n a v.
(Positive n, Vector a, v ~ T n a) =>
IO (Vector v -> Vector v)
makeReversePacked =
   ((Vector v -> Vector v) -> Vector v -> Vector v)
-> IO (Vector v -> Vector v) -> IO (Vector v -> Vector v)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Vector v -> Vector v
f -> [Vector v] -> Vector v
forall a. Storable a => [Vector a] -> Vector a
SVL.fromChunks ([Vector v] -> Vector v)
-> (Vector v -> [Vector v]) -> Vector v -> Vector v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Vector v] -> [Vector v]
forall a. [a] -> [a]
reverse ([Vector v] -> [Vector v])
-> (Vector v -> [Vector v]) -> Vector v -> [Vector v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector v -> Vector v) -> [Vector v] -> [Vector v]
forall a b. (a -> b) -> [a] -> [b]
map Vector v -> Vector v
f ([Vector v] -> [Vector v])
-> (Vector v -> [Vector v]) -> Vector v -> [Vector v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector v -> [Vector v]
forall a. Vector a -> [Vector a]
SVL.chunks) (IO (Vector v -> Vector v) -> IO (Vector v -> Vector v))
-> IO (Vector v -> Vector v) -> IO (Vector v -> Vector v)
forall a b. (a -> b) -> a -> b
$
   IO (Vector v -> Vector v)
forall n a v.
(Positive n, Vector a, v ~ T n a) =>
IO (Vector v -> Vector v)
makeReversePackedStrict


-- ToDo: move to synthesizer-core or storablevector
{- |
Append two signals where the second signal
gets the last value of the first signal as parameter.
If the first signal is empty
then there is no parameter for the second signal
and thus we simply return an empty signal in that case.
-}
continue ::
   (Storable a) =>
   SVL.Vector a -> (a -> SVL.Vector a) -> SVL.Vector a
continue :: forall a. Storable a => Vector a -> (a -> Vector a) -> Vector a
continue Vector a
x a -> Vector a
y =
   [Vector a] -> Vector a
forall a. Storable a => [Vector a] -> Vector a
SVL.fromChunks ([Vector a] -> Vector a) -> [Vector a] -> Vector a
forall a b. (a -> b) -> a -> b
$
   Vector a -> [Vector a] -> (Vector a -> [Vector a]) -> [Vector a]
forall a. a -> [a] -> (a -> [a]) -> [a]
withLast Vector a
forall a. Storable a => Vector a
SV.empty
      (Vector a -> [Vector a]
forall a. Vector a -> [Vector a]
SVL.chunks Vector a
x)
      ([Vector a]
-> (Vector a -> a -> [Vector a]) -> Vector a -> [Vector a]
forall a b.
Storable a =>
b -> (Vector a -> a -> b) -> Vector a -> b
SV.switchR [] ((Vector a -> a -> [Vector a]) -> Vector a -> [Vector a])
-> (Vector a -> a -> [Vector a]) -> Vector a -> [Vector a]
forall a b. (a -> b) -> a -> b
$ \Vector a
_ -> Vector a -> [Vector a]
forall a. Vector a -> [Vector a]
SVL.chunks (Vector a -> [Vector a]) -> (a -> Vector a) -> a -> [Vector a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Vector a
y)

continuePacked ::
   (TypeNum.Positive n, Storable.Vector a) =>
   SVL.Vector (Serial.T n a) ->
   (a -> SVL.Vector (Serial.T n a)) ->
   SVL.Vector (Serial.T n a)
continuePacked :: forall n a.
(Positive n, Vector a) =>
Vector (T n a) -> (a -> Vector (T n a)) -> Vector (T n a)
continuePacked Vector (T n a)
x a -> Vector (T n a)
y =
   [Vector (T n a)] -> Vector (T n a)
forall a. Storable a => [Vector a] -> Vector a
SVL.fromChunks ([Vector (T n a)] -> Vector (T n a))
-> [Vector (T n a)] -> Vector (T n a)
forall a b. (a -> b) -> a -> b
$
   Vector (T n a)
-> [Vector (T n a)]
-> (Vector (T n a) -> [Vector (T n a)])
-> [Vector (T n a)]
forall a. a -> [a] -> (a -> [a]) -> [a]
withLast Vector (T n a)
forall a. Storable a => Vector a
SV.empty
      (Vector (T n a) -> [Vector (T n a)]
forall a. Vector a -> [Vector a]
SVL.chunks Vector (T n a)
x)
      ([Vector (T n a)]
-> (Vector a -> a -> [Vector (T n a)])
-> Vector a
-> [Vector (T n a)]
forall a b.
Storable a =>
b -> (Vector a -> a -> b) -> Vector a -> b
SV.switchR [] (\Vector a
_ -> Vector (T n a) -> [Vector (T n a)]
forall a. Vector a -> [Vector a]
SVL.chunks (Vector (T n a) -> [Vector (T n a)])
-> (a -> Vector (T n a)) -> a -> [Vector (T n a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Vector (T n a)
y) (Vector a -> [Vector (T n a)])
-> (Vector (T n a) -> Vector a)
-> Vector (T n a)
-> [Vector (T n a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (T n a) -> Vector a
forall n a. (Positive n, Vector a) => Vector (T n a) -> Vector a
unpackStrict)

{-
This function reduces the last chunk to size one, repacks that
and takes the last value.
It would be certainly more efficient to use
a single @Memory.load@, @extractelement@ and @store@
instead of a loop of count 1.
However, this implementation is the simplest one, so far.
-}
{- |
Use this like

> do unpackGeneric <- makeUnpackGenericStrict
>    return (continuePackedGeneric unpackGeneric x y)
-}
continuePackedGeneric ::
   (Storable v, Storable a) =>
   (SV.Vector v -> SV.Vector a) ->
   SVL.Vector v -> (a -> SVL.Vector v) -> SVL.Vector v
continuePackedGeneric :: forall v a.
(Storable v, Storable a) =>
(Vector v -> Vector a) -> Vector v -> (a -> Vector v) -> Vector v
continuePackedGeneric Vector v -> Vector a
unpackGeneric Vector v
x a -> Vector v
y =
   [Vector v] -> Vector v
forall a. Storable a => [Vector a] -> Vector a
SVL.fromChunks ([Vector v] -> Vector v) -> [Vector v] -> Vector v
forall a b. (a -> b) -> a -> b
$
   Vector v -> [Vector v] -> (Vector v -> [Vector v]) -> [Vector v]
forall a. a -> [a] -> (a -> [a]) -> [a]
withLast Vector v
forall a. Storable a => Vector a
SV.empty
      (Vector v -> [Vector v]
forall a. Vector a -> [Vector a]
SVL.chunks Vector v
x)
      (\Vector v
lastChunk ->
         [Vector v]
-> (Vector a -> a -> [Vector v]) -> Vector a -> [Vector v]
forall a b.
Storable a =>
b -> (Vector a -> a -> b) -> Vector a -> b
SV.switchR [] (\Vector a
_ -> Vector v -> [Vector v]
forall a. Vector a -> [Vector a]
SVL.chunks (Vector v -> [Vector v]) -> (a -> Vector v) -> a -> [Vector v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Vector v
y) (Vector a -> [Vector v]) -> Vector a -> [Vector v]
forall a b. (a -> b) -> a -> b
$ Vector v -> Vector a
unpackGeneric (Vector v -> Vector a) -> Vector v -> Vector a
forall a b. (a -> b) -> a -> b
$
         Int -> Vector v -> Vector v
forall a. Storable a => Int -> Vector a -> Vector a
SV.drop (Vector v -> Int
forall a. Vector a -> Int
SV.length Vector v
lastChunk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Vector v -> Vector v) -> Vector v -> Vector v
forall a b. (a -> b) -> a -> b
$ Vector v
lastChunk)


-- ToDo: candidate for utility-ht
withLast :: a -> [a] -> (a -> [a]) -> [a]
withLast :: forall a. a -> [a] -> (a -> [a]) -> [a]
withLast a
deflt [a]
x a -> [a]
y =
   (a -> (a -> [a]) -> a -> [a]) -> (a -> [a]) -> [a] -> a -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      (\a
a a -> [a]
cont a
_ -> a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a]
cont a
a)
      a -> [a]
y [a]
x a
deflt


foreign import ccall safe "dynamic" derefFillPtr ::
   Exec.Importer (Word -> Ptr a -> IO ())

{- |
'fillBuffer' is not only more general than filling with zeros,
it also simplifies type inference.
-}
fillBuffer ::
   (Storable.C a, MultiValue.T a ~ value) =>
   value -> IO (Word -> Ptr a -> IO ())
fillBuffer :: forall a value.
(C a, T a ~ value) =>
value -> IO (Word -> Ptr a -> IO ())
fillBuffer value
x =
   String
-> Exec (Word -> Ptr a -> IO ()) -> IO (Word -> Ptr a -> IO ())
forall funcs. String -> Exec funcs -> IO funcs
Exec.compile String
"constant" (Exec (Word -> Ptr a -> IO ()) -> IO (Word -> Ptr a -> IO ()))
-> Exec (Word -> Ptr a -> IO ()) -> IO (Word -> Ptr a -> IO ())
forall a b. (a -> b) -> a -> b
$
   Importer (Word -> Ptr a -> IO ())
-> String
-> CodeGen (Word -> Ptr a -> IO ())
-> Exec (Word -> Ptr a -> IO ())
forall f.
(ExecutionFunction f, C f) =>
Importer f -> String -> CodeGen f -> Exec f
Exec.createFunction Importer (Word -> Ptr a -> IO ())
forall a. Importer (Word -> Ptr a -> IO ())
derefFillPtr String
"constantfill" (CodeGen (Word -> Ptr a -> IO ()) -> Exec (Word -> Ptr a -> IO ()))
-> CodeGen (Word -> Ptr a -> IO ())
-> Exec (Word -> Ptr a -> IO ())
forall a b. (a -> b) -> a -> b
$ \ Value Word
size Value (Ptr a)
ptr ->
      Value Word
-> Value (Ptr a)
-> ()
-> (Value (Ptr a) -> () -> CodeGenFunction () ())
-> CodeGenFunction () ()
forall s i a ptrA r.
(Phi s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i,
 Storable a, Value (Ptr a) ~ ptrA) =>
Value i
-> ptrA
-> s
-> (ptrA -> s -> CodeGenFunction r s)
-> CodeGenFunction r s
Storable.arrayLoop Value Word
size Value (Ptr a)
ptr () ((Value (Ptr a) -> () -> CodeGenFunction () ())
 -> CodeGenFunction () ())
-> (Value (Ptr a) -> () -> CodeGenFunction () ())
-> CodeGenFunction () ()
forall a b. (a -> b) -> a -> b
$ \ Value (Ptr a)
ptri () -> T a -> Value (Ptr a) -> CodeGenFunction () ()
forall r. T a -> Value (Ptr a) -> CodeGenFunction r ()
forall a r. C a => T a -> Value (Ptr a) -> CodeGenFunction r ()
Storable.store value
T a
x Value (Ptr a)
ptri


foreign import ccall safe "dynamic" derefMixPtr ::
   Exec.Importer (Word -> Ptr a -> Ptr a -> IO ())

makeMixer ::
   (Storable.C a, MultiValue.T a ~ value) =>
   (value -> value -> LLVM.CodeGenFunction () value) ->
   IO (Word -> Ptr a -> Ptr a -> IO ())
makeMixer :: forall a value.
(C a, T a ~ value) =>
(value -> value -> CodeGenFunction () value)
-> IO (Word -> Ptr a -> Ptr a -> IO ())
makeMixer value -> value -> CodeGenFunction () value
add =
   String
-> Exec (Word -> Ptr a -> Ptr a -> IO ())
-> IO (Word -> Ptr a -> Ptr a -> IO ())
forall funcs. String -> Exec funcs -> IO funcs
Exec.compile String
"mixer" (Exec (Word -> Ptr a -> Ptr a -> IO ())
 -> IO (Word -> Ptr a -> Ptr a -> IO ()))
-> Exec (Word -> Ptr a -> Ptr a -> IO ())
-> IO (Word -> Ptr a -> Ptr a -> IO ())
forall a b. (a -> b) -> a -> b
$
   Importer (Word -> Ptr a -> Ptr a -> IO ())
-> String
-> CodeGen (Word -> Ptr a -> Ptr a -> IO ())
-> Exec (Word -> Ptr a -> Ptr a -> IO ())
forall f.
(ExecutionFunction f, C f) =>
Importer f -> String -> CodeGen f -> Exec f
Exec.createFunction Importer (Word -> Ptr a -> Ptr a -> IO ())
forall a. Importer (Word -> Ptr a -> Ptr a -> IO ())
derefMixPtr String
"mix" (CodeGen (Word -> Ptr a -> Ptr a -> IO ())
 -> Exec (Word -> Ptr a -> Ptr a -> IO ()))
-> CodeGen (Word -> Ptr a -> Ptr a -> IO ())
-> Exec (Word -> Ptr a -> Ptr a -> IO ())
forall a b. (a -> b) -> a -> b
$ \ Value Word
size Value (Ptr a)
srcPtr Value (Ptr a)
dstPtr ->
      CodeGenFunction () () -> CodeGenFunction () ()
forall (m :: * -> *) a. Monad m => m a -> m ()
void (CodeGenFunction () () -> CodeGenFunction () ())
-> CodeGenFunction () () -> CodeGenFunction () ()
forall a b. (a -> b) -> a -> b
$ Value Word
-> Value (Ptr a)
-> Value (Ptr a)
-> ()
-> (Value (Ptr a) -> Value (Ptr a) -> () -> CodeGenFunction () ())
-> CodeGenFunction () ()
forall s i a ptrA b ptrB r.
(Phi s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i,
 Storable a, Value (Ptr a) ~ ptrA, Storable b,
 Value (Ptr b) ~ ptrB) =>
Value i
-> ptrA
-> ptrB
-> s
-> (ptrA -> ptrB -> s -> CodeGenFunction r s)
-> CodeGenFunction r s
Storable.arrayLoop2 Value Word
size Value (Ptr a)
srcPtr Value (Ptr a)
dstPtr () ((Value (Ptr a) -> Value (Ptr a) -> () -> CodeGenFunction () ())
 -> CodeGenFunction () ())
-> (Value (Ptr a) -> Value (Ptr a) -> () -> CodeGenFunction () ())
-> CodeGenFunction () ()
forall a b. (a -> b) -> a -> b
$
            \Value (Ptr a)
srcPtri Value (Ptr a)
dstPtri () -> do
         T a
y <- Value (Ptr a) -> CodeGenFunction () (T a)
forall a r. C a => Value (Ptr a) -> CodeGenFunction r (T a)
forall r. Value (Ptr a) -> CodeGenFunction r (T a)
Storable.load Value (Ptr a)
srcPtri
         (value -> CodeGenFunction () value)
-> Value (Ptr a) -> CodeGenFunction () ()
forall a al r.
(C a, T a ~ al) =>
(al -> CodeGenFunction r al)
-> Value (Ptr a) -> CodeGenFunction r ()
Storable.modify (value -> value -> CodeGenFunction () value
add value
T a
y) Value (Ptr a)
dstPtri


addToBuffer ::
   (Storable a) =>
   (Word -> Ptr a -> Ptr a -> IO ()) ->
   Int -> Ptr a -> Int -> SVL.Vector a -> IO (Int, SVL.Vector a)
addToBuffer :: forall a.
Storable a =>
(Word -> Ptr a -> Ptr a -> IO ())
-> Int -> Ptr a -> Int -> Vector a -> IO (Int, Vector a)
addToBuffer Word -> Ptr a -> Ptr a -> IO ()
addChunkToBuffer Int
len Ptr a
v Int
start Vector a
xs =
   let (Vector a
now,Vector a
future) = Int -> Vector a -> (Vector a, Vector a)
forall a. Storable a => Int -> Vector a -> (Vector a, Vector a)
SVL.splitAt (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start) Vector a
xs
       go :: Int -> [Vector a] -> IO Int
go Int
i [] = Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
       go Int
i (Vector a
c:[Vector a]
cs) =
          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
c (\Ptr a
ptr Int
l ->
             Word -> Ptr a -> Ptr a -> IO ()
addChunkToBuffer (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l) Ptr a
ptr (Ptr a -> Int -> Ptr a
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr a
v Int
i)) IO () -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          Int -> [Vector a] -> IO Int
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Vector a -> Int
forall a. Vector a -> Int
SV.length Vector a
c) [Vector a]
cs
   in  (Int -> (Int, Vector a)) -> IO Int -> IO (Int, Vector a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Vector a -> (Int, Vector a))
-> Vector a -> Int -> (Int, Vector a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) Vector a
future) (IO Int -> IO (Int, Vector a))
-> (Vector a -> IO Int) -> Vector a -> IO (Int, Vector a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Vector a] -> IO Int
go Int
start ([Vector a] -> IO Int)
-> (Vector a -> [Vector a]) -> Vector a -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> [Vector a]
forall a. Vector a -> [Vector a]
SVL.chunks (Vector a -> IO (Int, Vector a)) -> Vector a -> IO (Int, Vector a)
forall a b. (a -> b) -> a -> b
$ Vector a
now


{-
Same algorithm as in Synthesizer.Storable.Cut.arrangeEquidist
-}
makeArranger ::
   (Storable.C a, MultiValue.Additive a) =>
   IO (SVL.ChunkSize ->
       EventList.T NonNeg.Int (SVL.Vector a) ->
       SVL.Vector a)
makeArranger :: forall a.
(C a, Additive a) =>
IO (ChunkSize -> 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 ())
makeMixer T a -> T a -> CodeGenFunction () (T a)
forall a r. Additive a => T a -> T a -> CodeGenFunction r (T a)
forall r. T a -> T a -> CodeGenFunction r (T a)
MultiValue.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 ())
fillBuffer T a
forall a. C a => T a
MultiValue.zero
   (ChunkSize -> T Int (Vector a) -> Vector a)
-> IO (ChunkSize -> T Int (Vector a) -> Vector a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ChunkSize -> T Int (Vector a) -> Vector a)
 -> IO (ChunkSize -> T Int (Vector a) -> Vector a))
-> (ChunkSize -> T Int (Vector a) -> Vector a)
-> IO (ChunkSize -> T Int (Vector a) -> Vector a)
forall a b. (a -> b) -> a -> b
$ \ (SVL.ChunkSize Int
sz) ->
      let sznn :: Int
sznn = String -> Int -> Int
forall a. (Ord a, C a) => String -> a -> T a
NonNeg.fromNumberMsg String
"arrange" Int
sz
          go :: [Vector a] -> T Int (Vector a) -> [Vector a]
go [Vector a]
acc T Int (Vector a)
evs =
             let (T Int (Vector a)
now,T Int (Vector a)
future) = Int -> T Int (Vector a) -> (T Int (Vector a), T Int (Vector a))
forall time body.
C time =>
time -> T time body -> (T time body, T time body)
EventListTM.splitAtTime Int
sznn T Int (Vector a)
evs
                 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 -> 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
                 (Vector a
chunk,[Vector a]
newAcc) =
                    IO (Vector a, [Vector a]) -> (Vector a, [Vector a])
forall a. IO a -> a
Unsafe.performIO (IO (Vector a, [Vector a]) -> (Vector a, [Vector a]))
-> IO (Vector a, [Vector a]) -> (Vector a, [Vector a])
forall a b. (a -> b) -> a -> b
$
                    Int
-> (Ptr a -> IO (Int, Int, [Vector a]))
-> IO (Vector a, [Vector a])
forall a b.
Storable a =>
Int -> (Ptr a -> IO (Int, Int, b)) -> IO (Vector a, b)
SVB.createAndTrim' Int
sz ((Ptr a -> IO (Int, Int, [Vector a])) -> IO (Vector a, [Vector a]))
-> (Ptr a -> IO (Int, Int, [Vector a]))
-> IO (Vector a, [Vector a])
forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> do
                       Word -> Ptr a -> IO ()
fill (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz) Ptr a
ptr
                       [(Int, Vector a)]
newAcc0 <- ((Vector a -> IO (Int, Vector a))
 -> [Vector a] -> IO [(Int, Vector a)])
-> [Vector a]
-> (Vector a -> IO (Int, Vector a))
-> IO [(Int, Vector a)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Vector a -> IO (Int, Vector a))
-> [Vector a] -> IO [(Int, Vector a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Vector a]
acc ((Vector a -> IO (Int, Vector a)) -> IO [(Int, Vector a)])
-> (Vector a -> IO (Int, Vector a)) -> IO [(Int, Vector a)]
forall a b. (a -> b) -> a -> b
$ (Word -> Ptr a -> Ptr a -> IO ())
-> Int -> Ptr a -> Int -> Vector a -> IO (Int, Vector a)
forall a.
Storable a =>
(Word -> Ptr a -> Ptr a -> IO ())
-> Int -> Ptr a -> Int -> Vector a -> IO (Int, Vector a)
addToBuffer Word -> Ptr a -> Ptr a -> IO ()
mixer Int
sz Ptr a
ptr Int
0
                       [(Int, Vector a)]
newAcc1 <- (((Int, Vector a) -> IO (Int, Vector a))
 -> [(Int, Vector a)] -> IO [(Int, Vector a)])
-> [(Int, Vector a)]
-> ((Int, Vector a) -> IO (Int, Vector a))
-> IO [(Int, Vector a)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int, Vector a) -> IO (Int, Vector a))
-> [(Int, Vector a)] -> IO [(Int, Vector a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [(Int, Vector a)]
xs (((Int, Vector a) -> IO (Int, Vector a)) -> IO [(Int, Vector a)])
-> ((Int, Vector a) -> IO (Int, Vector a)) -> IO [(Int, Vector a)]
forall a b. (a -> b) -> a -> b
$ \(Int
i,Vector a
s) ->
                          (Word -> Ptr a -> Ptr a -> IO ())
-> Int -> Ptr a -> Int -> Vector a -> IO (Int, Vector a)
forall a.
Storable a =>
(Word -> Ptr a -> Ptr a -> IO ())
-> Int -> Ptr a -> Int -> Vector a -> IO (Int, Vector a)
addToBuffer Word -> Ptr a -> Ptr a -> IO ()
mixer Int
sz Ptr a
ptr (Int -> Int
forall a. T a -> a
NonNeg.toNumber Int
i) Vector a
s
                       let ([Int]
ends, [Vector a]
suffixes) = [(Int, Vector a)] -> ([Int], [Vector a])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Int, Vector a)] -> ([Int], [Vector a]))
-> [(Int, Vector a)] -> ([Int], [Vector a])
forall a b. (a -> b) -> a -> b
$ [(Int, Vector a)]
newAcc0[(Int, Vector a)] -> [(Int, Vector a)] -> [(Int, Vector a)]
forall a. [a] -> [a] -> [a]
++[(Int, Vector a)]
newAcc1
                           {- if there are more events to come,
                              we must pad with zeros -}
                           len :: Int
len =
                              if T Int (Vector a) -> Bool
forall time body. T time body -> Bool
EventList.null T Int (Vector a)
future
                                then (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 [Int]
ends
                                else Int
sz
                       (Int, Int, [Vector a]) -> IO (Int, Int, [Vector a])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, Int
len,
                               (Vector a -> Bool) -> [Vector a] -> [Vector a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Vector a -> Bool) -> Vector a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> Bool
forall a. Storable a => Vector a -> Bool
SVL.null) [Vector a]
suffixes)
             in  if Vector a -> Bool
forall a. Vector a -> Bool
SV.null Vector a
chunk
                   then []
                   else Vector a
chunk Vector a -> [Vector a] -> [Vector a]
forall a. a -> [a] -> [a]
: [Vector a] -> T Int (Vector a) -> [Vector a]
go [Vector a]
newAcc T Int (Vector a)
future
      in  [Vector a] -> Vector a
forall a. Storable a => [Vector a] -> Vector a
SVL.fromChunks ([Vector a] -> Vector a)
-> (T Int (Vector a) -> [Vector a]) -> T Int (Vector a) -> Vector a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Vector a] -> T Int (Vector a) -> [Vector a]
go []