module Synthesizer.LLVM.Storable.Signal (
unpackStrict, unpack,
unpackStereoStrict, unpackStereo,
makeUnpackGenericStrict, makeUnpackGeneric,
makeReversePackedStrict, makeReversePacked,
continue, continuePacked, continuePackedGeneric,
fillBuffer, makeMixer, addToBuffer,
makeArranger, arrange,
) where
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS
import qualified Synthesizer.LLVM.Execution as Exec
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoVector
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.Extra.Memory as Memory
import qualified LLVM.Extra.Arithmetic as A
import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )
import LLVM.Extra.Control (arrayLoop, )
import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )
import qualified LLVM.Core as LLVM
import LLVM.Core (IsPrimitive, ret, getElementPtr, )
import qualified Type.Data.Num.Decimal as TypeNum
import qualified Control.Category as Cat
import qualified Data.List.HT as ListHT
import Data.Word (Word32, )
import Data.Int (Int32, )
import Foreign.Ptr (Ptr, )
import Foreign.ForeignPtr (castForeignPtr, )
import Foreign.Storable (Storable, )
import Foreign.Marshal.Array (advancePtr, )
import qualified System.Unsafe as Unsafe
import NumericPrelude.Numeric
import NumericPrelude.Base
unpackStrict ::
(Storable a, IsPrimitive a, TypeNum.Positive n) =>
SV.Vector (Serial.Plain n a) -> SV.Vector a
unpackStrict v =
let getDim ::
(TypeNum.Positive n) =>
SV.Vector (Serial.Plain n a) -> TypeNum.Singleton n -> Int
getDim _ = TypeNum.integralFromSingleton
d = getDim v TypeNum.singleton
(fptr,s,l) = SVB.toForeignPtr v
in SVB.SV (castForeignPtr fptr) (s*d) (l*d)
unpack ::
(Storable a, IsPrimitive a, TypeNum.Positive n) =>
SVL.Vector (Serial.Plain n a) -> SVL.Vector a
unpack =
SVL.fromChunks . map unpackStrict . SVL.chunks
unpackStereoStrict ::
(Storable a, IsPrimitive a, TypeNum.Positive n) =>
SV.Vector (StereoVector.T n a) -> SV.Vector (Stereo.T a)
unpackStereoStrict v =
let getDim ::
(TypeNum.Positive n) =>
SV.Vector (StereoVector.T n a) -> TypeNum.Singleton n -> Int
getDim _ = TypeNum.integralFromSingleton
d = getDim v TypeNum.singleton
(fptr,s,l) = SVB.toForeignPtr v
in SVB.SV (castForeignPtr fptr) (s*d) (l*d)
unpackStereo ::
(Storable a, IsPrimitive a, TypeNum.Positive n) =>
SVL.Vector (StereoVector.T n a) -> SVL.Vector (Stereo.T a)
unpackStereo =
SVL.fromChunks . map unpackStereoStrict . SVL.chunks
makeUnpackGenericStrict ::
(Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv,
Memory.C (Serial.ReadIt vv),
Storable a, MakeValueTuple a, ValueTuple a ~ va, Memory.C va,
Storable v, MakeValueTuple v, ValueTuple v ~ vv, Memory.C vv) =>
IO (SV.Vector v -> SV.Vector a)
makeUnpackGenericStrict =
let vectorSize ::
(Serial.C vl, n ~ Serial.Size vl, al ~ Serial.Element vl,
Storable v, MakeValueTuple v, ValueTuple v ~ vl) =>
SV.Vector v -> TypeNum.Singleton n
vectorSize _ = TypeNum.singleton
in fmap (\f v -> f (TypeNum.integralFromSingleton (vectorSize v) * SV.length v) v) $
SigP.run (SigPS.unpack $ SigP.fromStorableVector Cat.id)
makeUnpackGeneric ::
(Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv,
Memory.C (Serial.ReadIt vv),
Storable a, MakeValueTuple a, ValueTuple a ~ va, Memory.C va,
Storable v, MakeValueTuple v, ValueTuple v ~ vv, Memory.C vv) =>
IO (SVL.Vector v -> SVL.Vector a)
makeUnpackGeneric =
fmap (\f -> SVL.fromChunks . map f . SVL.chunks) $
makeUnpackGenericStrict
makeReverser ::
(Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
(value -> LLVM.CodeGenFunction () value) ->
IO (Word32 -> Ptr a -> Ptr a -> IO ())
makeReverser rev =
fmap (\f len srcPtr dstPtr ->
f len (Memory.castTuplePtr srcPtr) (Memory.castTuplePtr dstPtr)) $
Exec.compileModule $
Exec.createFunction derefMixPtr "reverse" $ \ size ptrA ptrB -> do
ptrAEnd <- getElementPtr ptrA (size, ())
_ <- arrayLoop size ptrB ptrAEnd $ \ ptrBi ptrAj0 -> do
ptrAj1 <- getElementPtr ptrAj0 (1 :: Int32, ())
flip Memory.store ptrBi
=<< rev
=<< Memory.load ptrAj1
return ptrAj1
ret ()
makeReversePackedStrict ::
(Storable v, Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv,
MakeValueTuple v, ValueTuple v ~ vv, Memory.C vv) =>
IO (SV.Vector v -> SV.Vector v)
makeReversePackedStrict = do
rev <- makeReverser Serial.reverse
return $ \v ->
Unsafe.performIO $
SVB.withStartPtr v $ \ptrA len ->
SVB.create len $ \ptrB ->
rev (fromIntegral len) ptrA ptrB
makeReversePacked ::
(Storable v, Serial.C vv, n ~ Serial.Size vv, va ~ Serial.Element vv,
MakeValueTuple v, ValueTuple v ~ vv, Memory.C vv) =>
IO (SVL.Vector v -> SVL.Vector v)
makeReversePacked =
fmap (\f -> SVL.fromChunks . reverse . map f . SVL.chunks) $
makeReversePackedStrict
continue ::
(Storable a) =>
SVL.Vector a -> (a -> SVL.Vector a) -> SVL.Vector a
continue x y =
SVL.fromChunks $
withLast SV.empty
(SVL.chunks x)
(SV.switchR [] $ \_ -> SVL.chunks . y)
_continueNeglectLast ::
(Storable a) =>
SVL.Vector a -> (a -> SVL.Vector a) -> SVL.Vector a
_continueNeglectLast x y =
SVL.switchR SVL.empty
(\body l -> SVL.append body (y l)) x
continuePacked ::
(TypeNum.Positive n, Storable a, IsPrimitive a) =>
SVL.Vector (Serial.Plain n a) ->
(a -> SVL.Vector (Serial.Plain n a)) ->
SVL.Vector (Serial.Plain n a)
continuePacked x y =
SVL.fromChunks $
withLast SV.empty
(SVL.chunks x)
(SV.switchR [] (\_ -> SVL.chunks . y) .
unpackStrict)
continuePackedGeneric ::
(Storable v, Storable a) =>
(SV.Vector v -> SV.Vector a) ->
SVL.Vector v -> (a -> SVL.Vector v) -> SVL.Vector v
continuePackedGeneric unpackGeneric x y =
SVL.fromChunks $
withLast SV.empty
(SVL.chunks x)
(\lastChunk ->
SV.switchR [] (\_ -> SVL.chunks . y) $ unpackGeneric $
SV.drop (SV.length lastChunk 1) $ lastChunk)
withLast :: a -> [a] -> (a -> [a]) -> [a]
withLast deflt x y =
foldr
(\a cont _ -> a : cont a)
y x deflt
_withLast :: [a] -> (a -> [a]) -> [a]
_withLast x y =
ListHT.switchR []
(\body end -> body ++ end : y end)
x
foreign import ccall safe "dynamic" derefFillPtr ::
Exec.Importer (Word32 -> Ptr a -> IO ())
fillBuffer ::
(MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
value -> IO (Word32 -> Ptr a -> IO ())
fillBuffer x =
fmap (\f len ptr -> f len (Memory.castTuplePtr ptr)) $
Exec.compileModule $
Exec.createFunction derefFillPtr "constantfill" $ \ size ptr -> do
arrayLoop size ptr () $ \ ptri () -> do
Memory.store x ptri
return ()
ret ()
foreign import ccall safe "dynamic" derefMixPtr ::
Exec.Importer (Word32 -> Ptr a -> Ptr a -> IO ())
makeMixer ::
(Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
(value -> value -> LLVM.CodeGenFunction () value) ->
IO (Word32 -> Ptr a -> Ptr a -> IO ())
makeMixer add =
fmap (\f len srcPtr dstPtr ->
f len (Memory.castTuplePtr srcPtr) (Memory.castTuplePtr dstPtr)) $
Exec.compileModule $
Exec.createFunction derefMixPtr "mix" $ \ size srcPtr dstPtr -> do
_ <- arrayLoop size srcPtr dstPtr $ \ srcPtri dstPtri -> do
y <- Memory.load srcPtri
Memory.modify (add y) dstPtri
advanceArrayElementPtr dstPtri
ret ()
addToBuffer ::
(Storable a) =>
(Word32 -> Ptr a -> Ptr a -> IO ()) ->
Int -> Ptr a -> Int -> SVL.Vector a -> IO (Int, SVL.Vector a)
addToBuffer addChunkToBuffer len v start xs =
let (now,future) = SVL.splitAt (len start) xs
go i [] = return i
go i (c:cs) =
SVB.withStartPtr c (\ptr l ->
addChunkToBuffer (fromIntegral l) ptr (advancePtr v i)) >>
go (i + SV.length c) cs
in fmap (flip (,) future) . go start . SVL.chunks $ now
makeArranger ::
(Storable a, A.Additive value,
MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
IO (SVL.ChunkSize ->
EventList.T NonNeg.Int (SVL.Vector a) ->
SVL.Vector a)
makeArranger = do
mixer <- makeMixer A.add
fill <- fillBuffer A.zero
return $ \ (SVL.ChunkSize sz) ->
let sznn = NonNeg.fromNumberMsg "arrange" sz
go acc evs =
let (now,future) = EventListTM.splitAtTime sznn evs
xs =
AbsEventList.toPairList $
EventList.toAbsoluteEventList 0 $
EventListTM.switchTimeR const now
(chunk,newAcc) =
Unsafe.performIO $
SVB.createAndTrim' sz $ \ptr -> do
fill (fromIntegral sz) ptr
newAcc0 <- flip mapM acc $ addToBuffer mixer sz ptr 0
newAcc1 <- flip mapM xs $ \(i,s) ->
addToBuffer mixer sz ptr (NonNeg.toNumber i) s
let (ends, suffixes) = unzip $ newAcc0++newAcc1
len =
if EventList.null future
then foldl max 0 ends
else sz
return (0, len,
filter (not . SVL.null) suffixes)
in if SV.null chunk
then []
else chunk : go newAcc future
in SVL.fromChunks . go []
arrange ::
(Storable a, A.Additive value,
MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
SVL.ChunkSize
-> EventList.T NonNeg.Int (SVL.Vector a)
-> SVL.Vector a
arrange =
Unsafe.performIO makeArranger