{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{- |
Functions on lazy storable vectors that are implemented using LLVM.
-}
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



{-
Same algorithm as in Synthesizer.Storable.Cut.arrangeEquidist
-}
{- |
The element vectors in the event lists
must fit into the length of the event list.
-}
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 -- summation is done twice, for 'sz' and for 'xs'
          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)