Code.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Synthesizer.LLVM.Frame.SerialVector.Code (
   T(Cons), Value, size,
   fromOrdinary, toOrdinary,
   fromNiceVector, toNiceVector,
   extract, insert, modify,
   assemble, dissect,
   assemble1, dissect1,
   upsample, subsample, last,
   reverse, shiftUp, shiftUpMultiZero, shiftDown,
   cumulate, iterate,
   scale,
   ) where

import qualified LLVM.Extra.Nice.Vector.Instance as NiceVectorInst
import qualified LLVM.Extra.Nice.Vector as NiceVector
import qualified LLVM.Extra.Nice.Value.Storable as Storable
import qualified LLVM.Extra.Nice.Value.Marshal as Marshal
import qualified LLVM.Extra.Nice.Value.Vector as NiceValueVec
import qualified LLVM.Extra.Nice.Value as NiceValue
import qualified LLVM.Extra.Arithmetic as A

import qualified LLVM.Core as LLVM

import qualified Type.Data.Num.Decimal as TypeNum

import qualified Foreign.Storable as Store
import Foreign.Storable (Storable)
import Foreign.Ptr (castPtr)

import Control.Applicative ((<$>))

import qualified Data.NonEmpty as NonEmpty
import Data.Word (Word32)
import Data.Tuple.HT (mapSnd)

import Prelude as P hiding (last, reverse, iterate)


newtype T n a = Cons (LLVM.Vector n a)
   deriving (Eq, Num)

type Value n a = NiceValue.T (T n a)

instance (TypeNum.Positive n, NiceVector.C a) => NiceValue.C (T n a) where
   type Repr (T n a) = NiceVector.Repr n a
   cons (Cons v) = fromOrdinary $ NiceValue.cons v
   undef = fromOrdinary NiceValue.undef
   zero = fromOrdinary NiceValue.zero
   phi bb = fmap fromOrdinary . NiceValue.phi bb . toOrdinary
   addPhi bb a b = NiceValue.addPhi bb (toOrdinary a) (toOrdinary b)

instance (Marshal.Vector n a) => Marshal.C (T n a) where
   pack (Cons v) = Marshal.pack v
   unpack = Cons . Marshal.unpack

instance (TypeNum.Positive n, Storable a) => Storable (T n a) where
   sizeOf (Cons v) = Store.sizeOf v
   alignment (Cons v) = Store.alignment v
   poke ptr (Cons v) = Store.poke (castPtr ptr) v
   peek ptr = Cons <$> Store.peek (castPtr ptr)

instance
   (TypeNum.Positive n, Storable.Vector a, NiceVector.C a) =>
      Storable.C (T n a) where
   load ptr = fmap fromOrdinary $ Storable.load =<< LLVM.bitcast ptr
   store v ptr = Storable.store (toOrdinary v) =<< LLVM.bitcast ptr

instance
   (TypeNum.Positive n, NiceVector.IntegerConstant a) =>
      NiceValue.IntegerConstant (T n a) where
   fromInteger' = fromNiceVector . NiceVector.fromInteger'

instance
   (TypeNum.Positive n, NiceVector.RationalConstant a) =>
      NiceValue.RationalConstant (T n a) where
   fromRational' = fromNiceVector . NiceVector.fromRational'

instance
   (TypeNum.Positive n, NiceVector.Additive a) =>
      NiceValue.Additive (T n a) where
   add = lift2 NiceVector.add
   sub = lift2 NiceVector.sub
   neg = lift1 NiceVector.neg

instance
   (TypeNum.Positive n, NiceVector.PseudoRing a) =>
      NiceValue.PseudoRing (T n a) where
   mul = lift2 NiceVector.mul

scale ::
   (TypeNum.Positive n, NiceVector.PseudoRing a) =>
   NiceValue.T a -> Value n a -> LLVM.CodeGenFunction r (Value n a)
scale = lift1 . NiceVector.scale

instance
   (TypeNum.Positive n, NiceVector.Real a) =>
      NiceValue.Real (T n a) where
   min = lift2 NiceVector.min
   max = lift2 NiceVector.max
   abs = lift1 NiceVector.abs
   signum = lift1 NiceVector.signum

instance
   (TypeNum.Positive n, NiceVector.Fraction a) =>
      NiceValue.Fraction (T n a) where
   truncate = lift1 NiceVector.truncate
   fraction = lift1 NiceVector.fraction

instance
   (TypeNum.Positive n, NiceVector.Field a) =>
      NiceValue.Field (T n a) where
   fdiv = lift2 NiceVector.fdiv

instance
   (TypeNum.Positive n, NiceVector.Algebraic a) =>
      NiceValue.Algebraic (T n a) where
   sqrt = lift1 NiceVector.sqrt

instance
   (TypeNum.Positive n, NiceVector.Transcendental a) =>
      NiceValue.Transcendental (T n a) where
   pi  = fmap fromNiceVector NiceVector.pi
   sin = lift1 NiceVector.sin
   log = lift1 NiceVector.log
   exp = lift1 NiceVector.exp
   cos = lift1 NiceVector.cos
   pow = lift2 NiceVector.pow

instance
   (TypeNum.Positive n, n ~ m,
    NiceVector.NativeInteger n a ar,
    NiceValue.NativeInteger a ar) =>
      NiceValueVec.NativeInteger (T n a) (LLVM.Vector m ar) where

instance
   (TypeNum.Positive n, n ~ m,
    NiceVector.NativeFloating n a ar,
    NiceValue.NativeFloating a ar) =>
      NiceValueVec.NativeFloating (T n a) (LLVM.Vector m ar) where

lift1 ::
   (Functor f) =>
   (NiceVector.T n a -> f (NiceVector.T m b)) ->
   (Value n a -> f (Value m b))
lift1 f a = fromNiceVector <$> f (toNiceVector a)

lift2 ::
   (Functor f) =>
   (NiceVector.T n a -> NiceVector.T m b -> f (NiceVector.T k c)) ->
   (Value n a -> Value m b -> f (Value k c))
lift2 f a b = fromNiceVector <$> f (toNiceVector a) (toNiceVector b)


extract ::
   (TypeNum.Positive n,
    NiceVector.C x, NiceValue.T x ~ a, Value n x ~ v) =>
   LLVM.Value Word32 -> v -> LLVM.CodeGenFunction r a
extract i v = NiceVector.extract i (toNiceVector v)

insert ::
   (TypeNum.Positive n,
    NiceVector.C x, NiceValue.T x ~ a, Value n x ~ v) =>
   LLVM.Value Word32 -> a -> v -> LLVM.CodeGenFunction r v
insert i a v =
    fromNiceVector <$> NiceVector.insert i a (toNiceVector v)

modify ::
   (TypeNum.Positive n,
    NiceVector.C x, NiceValue.T x ~ a, Value n x ~ v) =>
   LLVM.Value Word32 ->
   (a -> LLVM.CodeGenFunction r a) ->
   v -> LLVM.CodeGenFunction r v
modify k f v = flip (insert k) v =<< f =<< extract k v


assemble ::
   (TypeNum.Positive n, NiceVector.C a) =>
   [NiceValue.T a] ->
   LLVM.CodeGenFunction r (Value n a)
assemble = fmap fromNiceVector . NiceVector.assemble

dissect ::
   (TypeNum.Positive n, NiceVector.C a) =>
   Value n a ->
   LLVM.CodeGenFunction r [NiceValue.T a]
dissect = NiceVector.dissect . toNiceVector

assemble1 ::
   (TypeNum.Positive n, NiceVector.C a) =>
   NonEmpty.T [] (NiceValue.T a) ->
   LLVM.CodeGenFunction r (Value n a)
assemble1 = fmap fromNiceVector . NiceVector.assemble1

dissect1 ::
   (TypeNum.Positive n, NiceVector.C a) =>
   Value n a ->
   LLVM.CodeGenFunction r (NonEmpty.T [] (NiceValue.T a))
dissect1 = NiceVector.dissect1 . toNiceVector


sizeS :: TypeNum.Positive n => Value n a -> TypeNum.Singleton n
sizeS _ = TypeNum.singleton

size :: (TypeNum.Positive n, P.Integral i) => Value n a -> i
size = TypeNum.integralFromSingleton . sizeS


last ::
   (TypeNum.Positive n, NiceVector.C a) =>
   Value n a -> LLVM.CodeGenFunction r (NiceValue.T a)
last v = extract (LLVM.valueOf (size v - 1 :: Word32)) v

subsample ::
   (TypeNum.Positive n, NiceVector.C a) =>
   Value n a -> LLVM.CodeGenFunction r (NiceValue.T a)
subsample = extract (A.zero :: LLVM.Value Word32)

upsample ::
   (TypeNum.Positive n, NiceVector.C a) =>
   NiceValue.T a -> LLVM.CodeGenFunction r (Value n a)
upsample = fmap fromOrdinary . NiceValueVec.replicate


reverse ::
   (TypeNum.Positive n, NiceVector.C a) =>
   Value n a -> LLVM.CodeGenFunction r (Value n a)
reverse =
   fmap fromNiceVector . NiceVector.reverse . toNiceVector

shiftUp ::
   (TypeNum.Positive n, NiceVector.C x,
    NiceValue.T x ~ a, Value n x ~ v) =>
   a -> v -> LLVM.CodeGenFunction r (a, v)
shiftUp a v =
   mapSnd fromNiceVector <$> NiceVector.shiftUp a (toNiceVector v)

shiftUpMultiZero ::
   (TypeNum.Positive n, NiceVector.C x, Value n x ~ v) =>
   Int -> v -> LLVM.CodeGenFunction r v
shiftUpMultiZero k v =
   fromNiceVector <$> NiceVector.shiftUpMultiZero k (toNiceVector v)

shiftDown ::
   (TypeNum.Positive n, NiceVector.C x,
    NiceValue.T x ~ a, Value n x ~ v) =>
   a -> v -> LLVM.CodeGenFunction r (a, v)
shiftDown a v =
   mapSnd fromNiceVector <$> NiceVector.shiftDown a (toNiceVector v)


iterate ::
   (TypeNum.Positive n, NiceVector.C a) =>
   (NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T a)) ->
   NiceValue.T a -> LLVM.CodeGenFunction r (Value n a)
iterate f = fmap fromOrdinary . NiceValueVec.iterate f

cumulate ::
   (TypeNum.Positive n, NiceVector.Additive a) =>
   NiceValue.T a -> Value n a ->
   LLVM.CodeGenFunction r (NiceValue.T a, Value n a)
cumulate a =
   fmap (mapSnd fromNiceVector) . NiceVector.cumulate a . toNiceVector


fromOrdinary :: NiceValue.T (LLVM.Vector n a) -> Value n a
fromOrdinary = NiceValue.cast

toOrdinary :: Value n a -> NiceValue.T (LLVM.Vector n a)
toOrdinary = NiceValue.cast

fromNiceVector :: NiceVector.T n a -> Value n a
fromNiceVector = fromOrdinary . NiceVectorInst.toNiceValue

toNiceVector :: Value n a -> NiceVector.T n a
toNiceVector = NiceVectorInst.fromNiceValue . toOrdinary