Signal.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Synthesizer.LLVM.Simple.Signal where

import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame as Frame
import qualified Synthesizer.LLVM.Wave as Wave
import qualified Synthesizer.LLVM.Execution as Exec

import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt
import qualified Synthesizer.LLVM.Storable.Vector as SVU
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB

import qualified LLVM.Extra.ForeignPtr as ForeignPtr
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.MaybeContinuation as MaybeCont
import qualified LLVM.Extra.Maybe as Maybe
import qualified LLVM.Extra.Arithmetic as A
import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )
import LLVM.Extra.Control (ifThen, )
import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )

import qualified LLVM.Core as LLVM
import LLVM.Util.Loop (Phi, )
import LLVM.Core
          (CodeGenFunction, ret, Value, valueOf,
           IsSized, IsConst, IsArithmetic,
           Linkage(ExternalLinkage), createNamedFunction)

import Control.Monad (liftM2, liftM3, )
import Control.Applicative (Applicative, pure, (<*>), liftA2, )

import qualified Number.Ratio as Ratio
import qualified Algebra.Transcendental as Trans
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive

import qualified System.Unsafe as Unsafe
import Foreign.Storable.Tuple ()
import Foreign.Storable (Storable, )
import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, )
import Foreign.Ptr (FunPtr, Ptr, nullPtr, )
import Data.Word (Word32, )
import Control.Exception (bracket, )

import NumericPrelude.Numeric
import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )

import qualified Prelude as P


{-
We need the forall quantification for 'CodeGenFunction's @r@ parameter.
This type parameter will be unified with the result type of the final function.
Since one piece of code can be used in multiple functions
we cannot yet fix the type @r@ here.

We might avoid code duplication by defining

> newtype T a = Cons (Causal.T () a)
-}
data T a =
   forall state ioContext.
      (Memory.C state) =>
      Cons (forall r c.
            (Phi c) =>
            ioContext ->
            state -> MaybeCont.T r c (a, state))
               -- compute next value
           (forall r.
            ioContext ->
            CodeGenFunction r state)
               -- initial state
           (IO ioContext)
               {- initialization from IO monad
               This will be run within Unsafe.performIO,
               so no observable In/Out actions please!
               -}
           (ioContext -> IO ())
               -- finalization from IO monad, also run within Unsafe.performIO


data Core context initState exitState a =
   forall state.
      (Memory.C state) =>
      Core (forall r c.
            (Phi c) =>
            context ->
            state -> MaybeCont.T r c (a, state))
               -- compute next value
           (forall r.
            initState ->
            CodeGenFunction r state)
               -- initial state
           (state -> exitState)
               -- extract final state for cleanup


class Applicative signal => C signal where
   simple ::
      (Memory.C state) =>
      (forall r c. state -> MaybeCont.T r c (a, state)) ->
      (forall r. CodeGenFunction r state) ->
      signal a

   alter ::
      (forall context initState exitState.
          Core context initState exitState a0 ->
          Core context initState exitState a1) ->
      signal a0 -> signal a1

instance C T where
   simple next start =
      Cons
         (const next)
         (const start)
         (return ())
         (const $ return ())

   alter f (Cons next0 start0 create delete) =
      case f (Core next0 start0 id) of
         Core next1 start1 _ ->
            Cons next1 start1 create delete


map ::
   (C signal) =>
   (forall r. a -> CodeGenFunction r b) -> signal a -> signal b
map f = alter (\(Core next start stop) ->
   Core
      (\ioContext sa0 -> do
         (a,sa1) <- next ioContext sa0
         b <- MaybeCont.lift $ f a
         return (b, sa1))
      start
      stop)

mapAccum ::
   (C signal, Memory.C s) =>
   (forall r. a -> s -> CodeGenFunction r (b,s)) ->
   (forall r. CodeGenFunction r s) ->
   signal a -> signal b
mapAccum f startS = alter (\(Core next start stop) ->
   Core
      (\ioContext (sa0,ss0) -> do
         (a,sa1) <- next ioContext sa0
         (b,ss1) <- MaybeCont.lift $ f a ss0
         return (b, (sa1,ss1)))
      (\ioContext ->
         liftM2 (,) (start ioContext) startS)
      (stop . fst))


zipWith ::
   (C signal) =>
   (forall r. a -> b -> CodeGenFunction r c) ->
   signal a -> signal b -> signal c
zipWith f a b  =  map (uncurry f) $ liftA2 (,) a b

zip :: T a -> T b -> T (a,b)
zip (Cons nextA startA createIOContextA deleteIOContextA)
    (Cons nextB startB createIOContextB deleteIOContextB) =
   Cons
      (\(ioContextA, ioContextB) (sa0,sb0) -> do
         (a,sa1) <- nextA ioContextA sa0
         (b,sb1) <- nextB ioContextB sb0
         return ((a,b), (sa1,sb1)))
      (\(ioContextA, ioContextB) ->
         liftM2 (,)
            (startA ioContextA)
            (startB ioContextB))
      (liftM2 (,)
         createIOContextA
         createIOContextB)
      (\(ca,cb) ->
         deleteIOContextA ca >>
         deleteIOContextB cb)


instance Functor T where
   fmap f = map (return . f)

{- |
ZipList semantics
-}
instance Applicative T where
   pure x = simple (\() -> return (x, ())) (return ())
   f <*> a = fmap (uncurry ($)) $ zip f a

instance (A.Additive a) => Additive.C (T a) where
   zero = pure A.zero
   negate = map A.neg
   (+) = zipWith A.add
   (-) = zipWith A.sub

instance (A.PseudoRing a, A.IntegerConstant a) => Ring.C (T a) where
   one = pure A.one
   fromInteger n = pure (A.fromInteger' n)
   (*) = zipWith A.mul

instance (A.Field a, A.RationalConstant a) => Field.C (T a) where
   fromRational' x = pure (A.fromRational' $ Ratio.toRational98 x)
   (/) = zipWith A.fdiv


instance (A.PseudoRing a, A.Real a, A.IntegerConstant a) => P.Num (T a) where
   fromInteger n = pure (A.fromInteger' n)
   negate = map A.neg
   (+) = zipWith A.add
   (-) = zipWith A.sub
   (*) = zipWith A.mul
   abs = map A.abs
   signum = map A.signum

instance (A.Field a, A.Real a, A.RationalConstant a) => P.Fractional (T a) where
   fromRational x = pure (A.fromRational' x)
   (/) = zipWith A.fdiv


mix ::
   (C signal, A.Additive a) =>
   signal a -> signal a -> signal a
mix = zipWith Frame.mix


envelope ::
   (C signal, A.PseudoRing a) =>
   signal a -> signal a -> signal a
envelope = zipWith Frame.amplifyMono

envelopeStereo ::
   (C signal, A.PseudoRing a) =>
   signal a -> signal (Stereo.T a) -> signal (Stereo.T a)
envelopeStereo = zipWith Frame.amplifyStereo

amplify ::
   (IsArithmetic a, IsConst a) =>
   a -> T (Value a) -> T (Value a)
amplify x =
   map (Frame.amplifyMono (valueOf x))

amplifyStereo ::
   (IsArithmetic a, IsConst a) =>
   a -> T (Stereo.T (Value a)) -> T (Stereo.T (Value a))
amplifyStereo x =
   map (Frame.amplifyStereo (valueOf x))



iterate ::
   (Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, IsConst a) =>
   (forall r. Value a -> CodeGenFunction r (Value a)) ->
   Value a -> T (Value a)
iterate f initial =
   simple
      (\y -> MaybeCont.lift $ fmap (\y1 -> (y,y1)) (f y))
      (return initial)

exponential2 ::
   (Trans.C a, IsArithmetic a,
    Memory.FirstClass a, Memory.Stored a ~ am, IsSized am, IsConst a) =>
   a -> a -> T (Value a)
exponential2 halfLife =
   iterate (\y -> A.mul y (valueOf (0.5 ** recip halfLife))) . valueOf


osciPlain ::
   (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm,
    SoV.Fraction t, IsConst t) =>
   (forall r. Value t -> CodeGenFunction r y) ->
   Value t -> Value t -> T y
osciPlain wave phase freq =
   map wave $
   iterate (SoV.incPhase freq) $
   phase

osci ::
   (Memory.FirstClass t, Memory.Stored t ~ tm, IsSized tm,
    SoV.Fraction t, IsConst t) =>
   (forall r. Value t -> CodeGenFunction r y) ->
   t -> t -> T y
osci wave phase freq =
   osciPlain wave (valueOf phase) (valueOf freq)

osciSaw ::
   (SoV.IntegerConstant a,
    Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,
    SoV.Fraction a, IsConst a) =>
   a -> a -> T (Value a)
osciSaw = osci Wave.saw



fromStorableVector ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   SV.Vector a ->
   T value
fromStorableVector xs =
   let (fp,ptr,l) = SVU.unsafeToPointers xs
   in  Cons
          (\_ (p0,l0) -> do
             cont <- MaybeCont.lift $ A.cmp LLVM.CmpGT l0 A.zero
             MaybeCont.withBool cont $ do
                y1 <- Memory.load p0
                p1 <- advanceArrayElementPtr p0
                l1 <- A.dec l0
                return (y1,(p1,l1)))
          (const $ return
             (valueOf ptr,
              valueOf (fromIntegral l :: Word32)))
          -- keep the foreign ptr alive
          (return fp)
          touchForeignPtr

{-
This function calls back into the Haskell function 'nextChunk'
that returns a pointer to the data of the next chunk
and advances to the next chunk in the sequence.
-}
fromStorableVectorLazy ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   SVL.Vector a ->
   T value
fromStorableVectorLazy sig =
   Cons
      (\stable (buffer0,length0) -> do
         (buffer1,length1) <- MaybeCont.lift $ do
            nextChunkFn <- LLVM.staticFunction ChunkIt.nextCallBack
            needNext <- A.cmp LLVM.CmpEQ length0 A.zero
            ifThen needNext (buffer0,length0)
               (do lenPtr <- LLVM.alloca
                   liftM2 (,)
                      (LLVM.call nextChunkFn (valueOf stable) lenPtr)
                      (LLVM.load lenPtr))
         valid <- MaybeCont.lift $ A.cmp LLVM.CmpNE buffer1 (valueOf nullPtr)
         MaybeCont.withBool valid $ do
            x <- Memory.load buffer1
            buffer2 <- advanceArrayElementPtr buffer1
            length2 <- A.dec length1
            return (x, (buffer2,length2)))
      (const $ return (valueOf nullPtr, A.zero))
      (ChunkIt.new sig)
      ChunkIt.dispose


{-
compile ::
   (Memory.C value) =>
   T value ->
   CodeGenModule (Function (Word32 -> Ptr struct -> IO Word32))
-}

{-
We could also implement that in terms of getPointerToFunction
as done in Parameterized.Signal.
However, since the 'fill' function will be called only once,
it does not matter whether we use the Just-In-Time compiler
or compile once.
-}
render ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   Int -> T value -> SV.Vector a
render len (Cons next start createIOContext deleteIOContext) =
   Unsafe.performIO $
   bracket createIOContext deleteIOContext $ \ ioContext ->
   SVB.createAndTrim len $ \ ptr ->
      do fill <-
            Exec.runFunction $
            createNamedFunction ExternalLinkage "fillsignalblock" $ \ size bPtr -> do
               s <- start ioContext
               (pos,_) <- MaybeCont.arrayLoop size bPtr s $ \ ptri s0 -> do
                  (y,s1) <- next ioContext s0
                  MaybeCont.lift $ Memory.store y ptri
                  return s1
               ret (pos :: Value Word32)
         fmap (fromIntegral :: Word32 -> Int) $
            fill (fromIntegral len) (Memory.castStorablePtr ptr)


foreign import ccall safe "dynamic" derefChunkPtr ::
   Exec.Importer (Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)


compileChunky ::
   (Memory.C value, Memory.Struct value ~ struct,
    Memory.C state, Memory.Struct state ~ stateStruct) =>
   (forall r z.
    (Phi z) =>
    state -> MaybeCont.T r z (value, state)) ->
   (forall r.
    CodeGenFunction r state) ->
   IO (FunPtr (IO (Ptr stateStruct)),
       FunPtr (Ptr stateStruct -> IO ()),
       FunPtr (Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32))
compileChunky next start =
   Exec.compileModule $
      liftM3 (,,)
         (createNamedFunction ExternalLinkage "startsignal" $
          do
             pptr <- LLVM.malloc
             flip Memory.store pptr =<< start
             ret pptr)
{- for debugging: allocation with initialization makes type inference difficult
         (createNamedFunction ExternalLinkage "startsignal" $
          do
             pptr <- malloc
             let retn :: CodeGenFunction r state -> Value (Ptr state) -> CodeGenFunction (Ptr state) ()
                 retn _ ptr = ret ptr
             retn undefined pptr)
-}
         (createNamedFunction ExternalLinkage "stopsignal" $
          \ pptr -> LLVM.free pptr >> ret ())
         (createNamedFunction ExternalLinkage "fillsignal" $
          \ sptr loopLen ptr -> do
             sInit <- Memory.load sptr
             (pos,sExit) <- MaybeCont.arrayLoop loopLen ptr sInit $
              \ ptri s0 -> do
                (y,s1) <- next s0
                MaybeCont.lift $ Memory.store y ptri
                return s1
             Memory.store (Maybe.fromJust sExit) sptr
             ret (pos :: Value Word32))


runChunky ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   SVL.ChunkSize -> T value -> IO (SVL.Vector a)
runChunky (SVL.ChunkSize size)
     (Cons next start createIOContext deleteIOContext) = do
   ioContext <- createIOContext
   (startFunc, stopFunc, fill) <-
      compileChunky (next ioContext) (start ioContext)

   statePtr <- ForeignPtr.newInit stopFunc startFunc
   -- for explanation see Causal.Process
   ioContextPtr <- ForeignPtr.new (deleteIOContext ioContext) False

   let go =
         Unsafe.interleaveIO $ do
            v <-
               withForeignPtr statePtr $ \sptr ->
               SVB.createAndTrim size $
               fmap (fromIntegral :: Word32 -> Int) .
               derefChunkPtr fill sptr (fromIntegral size) .
               Memory.castStorablePtr
            touchForeignPtr ioContextPtr
            (if SV.length v > 0
               then fmap (v:)
               else id) $
               (if SV.length v < size
                  then return []
                  else go)
   fmap SVL.fromChunks go

renderChunky ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   SVL.ChunkSize -> T value -> SVL.Vector a
renderChunky size sig =
   Unsafe.performIO (runChunky size sig)