synthesizer-llvm-0.6: src/Synthesizer/LLVM/Parameterized/SignalPacked.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{- |
Signal generators that generate the signal in chunks
that can be processed natively by the processor.
Some of the functions for plain signals can be re-used without modification.
E.g. rendering a signal and reading from and to signals work
because the vector type as element type warrents correct alignment.
We can convert between atomic and chunked signals.
The article
<http://perilsofparallel.blogspot.com/2008/09/larrabee-vs-nvidia-mimd-vs-simd.html>
explains the difference between Vector and SIMD computing.
According to that the SSE extensions in Intel processors
must be called Vector computing.
But since we use the term Vector already in the mathematical sense,
I like to use the term "packed" that is used in Intel mnemonics like mulps.
-}
module Synthesizer.LLVM.Parameterized.SignalPacked where
import Synthesizer.LLVM.Parameterized.Signal (T(Cons), )
import Synthesizer.LLVM.Parameterized.SignalPrivate (withStart, )
import qualified Synthesizer.LLVM.Parameterized.Signal as Sig
import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.Random as Rnd
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.Vector as Vector
import qualified LLVM.Extra.MaybeContinuation as Maybe
import qualified LLVM.Extra.Control as U
import qualified LLVM.Extra.Arithmetic as A
import LLVM.Extra.Class (MakeValueTuple, ValueTuple, undefTuple, )
import qualified Types.Data.Num as TypeNum
import Types.Data.Num ((:*:), )
import qualified LLVM.Core as LLVM
import LLVM.Core
(CodeGenFunction, Value, valueOf,
IsSized, IsConst, IsArithmetic, IsFloating,
IsPrimitive, Vector, SizeOf, )
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import Control.Monad.HT ((<=<), )
import Control.Monad (replicateM, )
-- we can also use <$> for parameters
import Control.Arrow ((^<<), )
import Control.Applicative (liftA2, )
import qualified Algebra.Transcendental as Trans
import qualified Algebra.Algebraic as Algebraic
import qualified Algebra.RealField as RealField
import qualified Algebra.Ring as Ring
import Data.Word (Word32, )
import Data.Int (Int32, )
import Foreign.Storable (Storable, )
import qualified Data.List as List
import NumericPrelude.Numeric as NP
import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )
{- |
Convert a signal of scalar values into one using processor vectors.
If the signal length is not divisible by the chunk size,
then the last chunk is dropped.
-}
pack, packRotate ::
(Serial.C v, a ~ Serial.Element v) =>
T p a -> T p v
pack = packRotate
packRotate (Cons next start stop createIOContext deleteIOContext) = Cons
(\param s -> do
wInit <- Maybe.lift $ Serial.writeStart
(w2,_,s2) <-
Maybe.fromBool $
U.whileLoop
(valueOf True,
(wInit,
valueOf $ (fromIntegral $ Serial.sizeOfIterator wInit :: Word32),
s))
(\(cont,(_w0,i0,_s0)) ->
A.and cont =<<
A.cmp LLVM.CmpGT i0 A.zero)
(\(_,(w0,i0,s0)) -> Maybe.toBool $ do
(a,s1) <- next param s0
Maybe.lift $ do
w1 <- Serial.writeNext a w0
i1 <- A.dec i0
return (w1,i1,s1))
v <- Maybe.lift $ Serial.writeStop w2
return (v, s2))
start
stop
createIOContext
deleteIOContext
{-
We could reformulate it in terms of WriteIterator
that accesses elements using LLVM.extract.
We might move the loop counter into the Iterator,
but we have to assert that the counter is not duplicated.
packIndex ::
(Serial.C v, a ~ Serial.Element v) =>
T p a -> T p v
packIndex (Cons next start createIOContext deleteIOContext) = Cons
(\param s -> do
(v2,_,s2) <-
Maybe.fromBool $
U.whileLoop
(valueOf True, (undefTuple, A.zero, s))
(\(cont,(v0,i0,_s0)) ->
A.and cont =<<
A.cmp LLVM.CmpLT i0
(valueOf $ fromIntegral $ Serial.size v0))
(\(_,(v0,i0,s0)) -> Maybe.toBool $ do
(a,s1) <- next param s0
Maybe.lift $ do
v1 <- Vector.insert i0 a v0
i1 <- A.inc i0
return (v1,i1,s1))
return (v2, s2))
start
createIOContext
deleteIOContext
-}
{- |
Like 'pack' but duplicates the code for creating elements.
That is, for vectors of size n, the code of the input signal
will be emitted n times.
This is efficient only for simple input generators.
-}
packSmall ::
(Serial.C v, a ~ Serial.Element v) =>
T p a -> T p v
packSmall (Cons next start stop createIOContext deleteIOContext) = Cons
(\param ->
MS.runStateT $
case undefined of
vundef ->
fmap (flip asTypeOf vundef) .
MT.lift . Maybe.lift . Serial.assemble
=<<
replicateM (Serial.size vundef) (MS.StateT $ next param))
start
stop
createIOContext
deleteIOContext
unpack, unpackRotate ::
(Serial.Read v, a ~ Serial.Element v, Memory.C (Serial.ReadIt v)) =>
T p v -> T p a
unpack = unpackRotate
unpackRotate (Cons next start stop createIOContext deleteIOContext) = Cons
(\context (i0,r0,s0) -> do
endOfVector <-
Maybe.lift $ A.cmp LLVM.CmpEQ i0 (valueOf (0::Word32))
(i2,r2,s2) <-
Maybe.fromBool $
U.ifThen endOfVector (valueOf True, (i0,r0,s0)) $ do
(cont1, (v1,s1)) <- Maybe.toBool $ next context s0
r1 <- Serial.readStart v1
return (cont1, (valueOf $ fromIntegral $ Serial.size v1, r1, s1))
Maybe.lift $ do
(a,r3) <- Serial.readNext r2
i3 <- A.dec i2
return (a, (i3,r3,s2)))
(withStart start $ \s -> return (A.zero, undefTuple, s))
(\context (_,_,state) -> stop context state)
createIOContext
deleteIOContext
{-
We could reformulate it in terms of ReadIterator
that accesses elements using LLVM.extract.
We might move the loop counter into the Iterator,
but we have to assert that the counter is not duplicated.
unpackIndex ::
(Serial.C v, a ~ Serial.Element v, Memory.C v) =>
T p v -> T p a
unpackIndex (Cons next start createIOContext deleteIOContext) = Cons
(\param (i0,v0,s0) -> do
endOfVector <-
Maybe.lift $ A.cmp LLVM.CmpGE i0
(valueOf $ fromIntegral $ Serial.size v0)
(i2,v2,s2) <-
Maybe.fromBool $
U.ifThen endOfVector (valueOf True, (i0,v0,s0)) $ do
(cont1, (v1,s1)) <- Maybe.toBool $ next param s0
return (cont1, (A.zero, v1, s1))
Maybe.lift $ do
a <- Vector.extract i2 v2
i3 <- A.inc i2
return (a, (i3,v2,s2)))
(\p -> do
s <- start p
let v = undefTuple
return (valueOf $ fromIntegral $ Serial.size v, v, s))
createIOContext
deleteIOContext
-}
withSize ::
(n -> T p (Serial.Value n a)) ->
T p (Serial.Value n a)
withSize f = f undefined
withSizeRing ::
(Ring.C b, TypeNum.IntegerT n, TypeNum.PositiveT n) =>
(b -> T p (Serial.Value n a)) ->
T p (Serial.Value n a)
withSizeRing f =
withSize $ \n -> f (fromInteger $ TypeNum.fromIntegerT n)
constant ::
(Storable a, MakeValueTuple a, ValueTuple a ~ (Value a),
IsConst a,
Memory.FirstClass a, Memory.Stored a ~ am,
IsPrimitive a,
IsPrimitive am, IsSized am, SizeOf am ~ amsize,
TypeNum.PositiveT (n :*: amsize),
TypeNum.PositiveT n) =>
Param.T p a -> T p (Serial.Value n a)
constant x =
Sig.constant (Serial.replicate ^<< x)
exponential2 ::
(Trans.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a),
IsArithmetic a, IsConst a,
Memory.FirstClass a, Memory.Stored a ~ am,
IsPrimitive a, IsSized a, SizeOf a ~ as,
IsPrimitive am, IsSized am, SizeOf am ~ amsize,
TypeNum.PositiveT (n :*: as),
TypeNum.PositiveT (n :*: amsize),
TypeNum.IntegerT n, TypeNum.PositiveT n) =>
Param.T p a -> Param.T p a -> T p (Serial.Value n a)
exponential2 halfLife start = withSizeRing $ \n ->
Sig.exponentialCore
(Serial.replicate ^<< 0.5 ** (n / halfLife))
(liftA2
(\h -> Serial.fromList . List.iterate (0.5 ** recip h *))
halfLife start)
exponentialBounded2 ::
(Trans.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a),
Vector.Real a, IsConst a,
Memory.FirstClass a, Memory.Stored a ~ am,
IsPrimitive a, IsSized a, SizeOf a ~ as,
IsPrimitive am, IsSized am, SizeOf am ~ amsize,
TypeNum.PositiveT (n :*: as),
TypeNum.PositiveT (n :*: amsize),
TypeNum.IntegerT n, TypeNum.PositiveT n) =>
Param.T p a -> Param.T p a -> Param.T p a ->
T p (Serial.Value n a)
exponentialBounded2 bound halfLife start = withSizeRing $ \n ->
Sig.exponentialBoundedCore
(fmap (Serial.replicate) bound)
(Serial.replicate ^<< 0.5 ** (n / halfLife))
(liftA2
(\h -> Serial.fromList . List.iterate (0.5 ** recip h *))
halfLife start)
osciCore ::
(Storable t, MakeValueTuple t, ValueTuple t ~ (Value t),
Memory.FirstClass t, Memory.Stored t ~ tm,
IsPrimitive t, IsSized t, SizeOf t ~ tsize,
IsPrimitive tm, IsSized tm, SizeOf tm ~ tmsize,
TypeNum.PositiveT (n :*: tsize),
TypeNum.PositiveT (n :*: tmsize),
Vector.Real t, IsFloating t, RealField.C t, IsConst t,
TypeNum.IntegerT n, TypeNum.PositiveT n) =>
Param.T p t -> Param.T p t -> T p (Serial.Value n t)
osciCore phase freq = withSizeRing $ \n ->
Sig.osciCore
(liftA2
(\f -> Serial.fromList . List.iterate (fraction . (f +)))
freq phase)
(fmap
(\f -> Serial.replicate (fraction (n * f)))
freq)
osci ::
(Storable t, MakeValueTuple t, ValueTuple t ~ (Value t),
Storable c, MakeValueTuple c, ValueTuple c ~ cl,
Memory.FirstClass t, Memory.Stored t ~ tm,
IsPrimitive t, IsSized t, SizeOf t ~ tsize,
IsPrimitive tm, IsSized tm, SizeOf tm ~ tmsize,
TypeNum.PositiveT (n :*: tsize),
TypeNum.PositiveT (n :*: tmsize),
Memory.C cl,
Vector.Real t, IsFloating t, RealField.C t, IsConst t,
TypeNum.IntegerT n, TypeNum.PositiveT n) =>
(forall r. cl -> Serial.Value n t -> CodeGenFunction r y) ->
Param.T p c ->
Param.T p t -> Param.T p t -> T p y
osci wave waveParam phase freq =
Sig.map wave waveParam $
osciCore phase freq
osciSimple ::
(Storable t, MakeValueTuple t, ValueTuple t ~ (Value t),
Memory.FirstClass t, Memory.Stored t ~ tm,
IsPrimitive t, IsSized t, SizeOf t ~ tsize,
IsPrimitive tm, IsSized tm, SizeOf tm ~ tmsize,
TypeNum.PositiveT (n :*: tsize),
TypeNum.PositiveT (n :*: tmsize),
Vector.Real t, IsFloating t, RealField.C t, IsConst t,
TypeNum.IntegerT n, TypeNum.PositiveT n) =>
(forall r. Serial.Value n t -> CodeGenFunction r y) ->
Param.T p t -> Param.T p t -> T p y
osciSimple wave =
osci (const wave) (return ())
rampInf, rampSlope,
parabolaFadeInInf, parabolaFadeOutInf ::
(RealField.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a),
Memory.FirstClass a, Memory.Stored a ~ am,
IsPrimitive a, IsSized a, SizeOf a ~ as,
IsPrimitive am, IsSized am, SizeOf am ~ amsize,
TypeNum.PositiveT (n :*: as),
TypeNum.PositiveT (n :*: amsize),
IsArithmetic a, SoV.IntegerConstant a,
TypeNum.IntegerT n, TypeNum.PositiveT n) =>
Param.T p a -> T p (Serial.Value n a)
rampSlope slope = withSizeRing $ \n ->
Sig.rampCore
(fmap (\s -> Serial.replicate (n * s)) slope)
(fmap (\s -> Serial.fromList (List.iterate (s +) 0)) slope)
rampInf dur = rampSlope (recip dur)
parabolaFadeInInf dur = withSizeRing $ \n ->
Sig.parabolaCore
(fmap
(\dr ->
let d = n / dr
in Serial.replicate (-2*d*d)) dur)
(fmap
(\dr ->
let d = n / dr
in Serial.fromList $ List.iterate (subtract $ 2 / dr ^ 2) (d*(2-d)))
dur)
(fmap
(\dr ->
Serial.fromList $ List.map (\t -> t*(2-t)) $ List.iterate (recip dr +) 0)
dur)
parabolaFadeOutInf dur = withSizeRing $ \n ->
Sig.parabolaCore
(fmap
(\dr ->
let d = n / dr
in Serial.replicate (-2*d*d)) dur)
(fmap
(\dr ->
let d = n / dr
in Serial.fromList $ List.iterate (subtract $ 2 / dr ^ 2) (-d*d))
dur)
(fmap
(\dr ->
Serial.fromList $ List.map (\t -> 1-t*t) $ List.iterate (recip dr +) 0)
dur)
{- |
For the mysterious rate parameter see 'Sig.noise'.
-}
noise ::
(Algebraic.C a, IsFloating a, SoV.IntegerConstant a,
TypeNum.IntegerT n, TypeNum.PositiveT n,
TypeNum.PositiveT (n :*: TypeNum.D32),
Memory.FirstClass a, Memory.Stored a ~ am,
IsPrimitive a, IsSized a, SizeOf a ~ as,
IsPrimitive am, IsSized am, SizeOf am ~ amsize,
TypeNum.PositiveT (n :*: as),
TypeNum.PositiveT (n :*: amsize),
MakeValueTuple a, ValueTuple a ~ (Value a), Storable a) =>
Param.T p Word32 ->
Param.T p a ->
T p (Serial.Value n a)
noise seed rate =
let m2 = div Rnd.modulus 2
in Sig.map
(\r y ->
A.mul r
=<< flip A.sub (A.fromInteger' $ m2+1)
=<< int31tofp y)
(Serial.replicate ^<< sqrt (3 * rate) / return (fromInteger m2)) $
noiseCore seed
{-
sitofp is a single instruction on x86
and thus we use it, since the arguments are below 2^31.
-}
int31tofp ::
(IsFloating a, IsPrimitive a,
TypeNum.PositiveT n, TypeNum.PositiveT (n :*: TypeNum.D32)) =>
Serial.Value n Word32 -> CodeGenFunction r (Serial.Value n a)
int31tofp =
Serial.mapV $
LLVM.inttofp <=<
(LLVM.bitcast ::
(TypeNum.PositiveT n, TypeNum.PositiveT (n :*: TypeNum.D32)) =>
Value (Vector n Word32) ->
CodeGenFunction r (Value (Vector n Int32)))
noiseCore, noiseCoreAlt ::
(TypeNum.IntegerT n, TypeNum.PositiveT n,
TypeNum.PositiveT (n :*: TypeNum.D32)) =>
Param.T p Word32 ->
T p (Serial.Value n Word32)
noiseCore seed =
fmap Serial.value $
Sig.iterate (const Rnd.nextVector)
(return ())
(Rnd.vectorSeed . (+1) . flip mod (Rnd.modulus-1) ^<< seed)
noiseCoreAlt seed =
fmap Serial.value $
Sig.iterate (const Rnd.nextVector64)
(return ())
(Rnd.vectorSeed . (+1) . flip mod (Rnd.modulus-1) ^<< seed)