module Synthesizer.LLVM.Simple.Value where
import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.Arithmetic as A
import LLVM.Core hiding (zero, )
import qualified LLVM.Core as LLVM
import qualified LLVM.Util.Arithmetic as Arith
import qualified Synthesizer.Basic.Phase as Phase
import Control.Monad (liftM2, liftM3, )
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Algebra.Transcendental as Trans
import qualified Algebra.Algebraic as Algebraic
import qualified Algebra.RealRing as RealRing
import qualified Algebra.Module as Module
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import qualified Data.Traversable as Trav
import NumericPrelude.Numeric
import NumericPrelude.Base
newtype T a = Cons {decons :: forall r. Arith.TValue r a}
instance (IsArithmetic a, IsConst a) => Additive.C (T a) where
zero = constantValue (value LLVM.zero)
(+) = binop add
() = binop sub
negate (Cons x) = Cons (neg =<< x)
instance (Ring.C a, IsArithmetic a, IsConst a) =>
Ring.C (T a) where
one = constant one
(*) = binop mul
fromInteger = constant . fromInteger
instance (Ring.C a, IsArithmetic a, IsConst a) =>
Module.C (T a) (T a) where
(*>) = (*)
instance (Ring.C a, IsArithmetic a, IsConst a, IsPrimitive a, IsPowerOf2 n) =>
Module.C (T a) (T (Vector n a)) where
(Cons a) *> (Cons v) = Cons (do
a0 <- a
a1 <- SoV.replicate a0
A.mul a1 =<< v
)
instance (Ring.C a, IsArithmetic a, IsConst a) => Enum (T a) where
succ x = x + one
pred x = x one
fromEnum _ = error "CodeGenFunction Value: fromEnum"
toEnum = fromIntegral
instance (Field.C a, IsConst a, IsFloating a) => Field.C (T a) where
(/) = binop fdiv
fromRational' = constant . fromRational'
instance (Algebraic.C a, IsConst a, IsFloating a) => Algebraic.C (T a) where
sqrt = lift1 A.sqrt
instance (Trans.C a, IsConst a, IsFloating a) => Trans.C (T a) where
pi = constant pi
sin = lift1 A.sin
cos = lift1 A.cos
(**) = lift2 A.pow
exp = lift1 A.exp
log = lift1 A.log
asin _ = error "LLVM missing intrinsic: asin"
acos _ = error "LLVM missing intrinsic: acos"
atan _ = error "LLVM missing intrinsic: atan"
twoPi ::
(Trans.C a, IsConst a, IsFloating a) =>
T a
twoPi = 2*pi
lift1 ::
(forall r. Value a -> CodeGenFunction r (Value b)) ->
T a -> T b
lift1 f x =
Cons $ f =<< decons x
lift2 ::
(forall r. Value a -> Value b -> CodeGenFunction r (Value c)) ->
T a -> T b -> T c
lift2 f x y =
Cons $ uncurry f =<< liftM2 (,) (decons x) (decons y)
constantValue :: Value a -> T a
constantValue x =
Cons (return x)
constant :: (IsConst a) => a -> T a
constant = constantValue . valueOf
binop ::
(forall r. Value a -> Value b -> Arith.TValue r c) ->
T a -> T b -> T c
binop op x y = Cons (do
x' <- decons x
y' <- decons y
op x' y')
class Flatten value register | value -> register where
flatten :: value -> CodeGenFunction r register
unfold :: register -> value
flattenTraversable ::
(Flatten value register, Trav.Traversable f) =>
f value -> CodeGenFunction r (f register)
flattenTraversable =
Trav.mapM flatten
unfoldFunctor ::
(Flatten value register, Functor f) =>
f register -> f value
unfoldFunctor =
fmap unfold
instance (Flatten ah al, Flatten bh bl) =>
Flatten (ah,bh) (al,bl) where
flatten (a,b) =
liftM2 (,) (flatten a) (flatten b)
unfold (a,b) =
(unfold a, unfold b)
instance (Flatten ah al, Flatten bh bl, Flatten ch cl) =>
Flatten (ah,bh,ch) (al,bl,cl) where
flatten (a,b,c) =
liftM3 (,,) (flatten a) (flatten b) (flatten c)
unfold (a,b,c) =
(unfold a, unfold b, unfold c)
instance Flatten v r =>
Flatten (Stereo.T v) (Stereo.T r) where
flatten s =
liftM2 Stereo.cons
(flatten $ Stereo.left s)
(flatten $ Stereo.right s)
unfold s =
Stereo.cons
(unfold $ Stereo.left s)
(unfold $ Stereo.right s)
instance
(RealRing.C v, Flatten v r) =>
Flatten (Phase.T v) r where
flatten s =
flatten $ Phase.toRepresentative s
unfold s =
Phase.fromRepresentative $ unfold s
instance (IsConst a) => Flatten (T a) (Value a) where
flatten = decons
unfold = constantValue
instance Flatten () () where
flatten = return
unfold = id