RingBuffer.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Synthesizer.LLVM.RingBuffer (
   T, track, trackConst,
   index, oldest,
   ) where

import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP
import qualified Synthesizer.LLVM.Parameter as Param

import qualified LLVM.Extra.MaybeContinuation as Maybe
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Control as C
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Class as Class

import qualified LLVM.Core as LLVM
import LLVM.Core (CodeGenFunction, Value, )

import Data.Word (Word32, )
import Foreign.Storable.Tuple ()
import Foreign.Storable (Storable, )
import Foreign.Ptr (Ptr, )

import Prelude hiding (length, )


{-
I have chosen this type parameter
in order make sure that you can only retrieve from the buffer
what you have put into it.
E.g. if you store a SerialVector in it,
you can only load a SerialVector from it, but not a Vector,
although both of them use the same type for storage.
-}
data T a =
   Cons {
      buffer :: Value (Ptr (Memory.Struct a)),
      length :: Value Word32,
      current :: Value Word32,
      oldest_ :: Value Word32
   }

{- |
This function does not check for range violations.
If the ring buffer was generated by @track initial time@,
then the minimum index is zero and the maximum index is @time@.
Index zero refers to the current sample
and index @time@ refers to the oldest one.
-}
index ::
   (Memory.C a) =>
   Value Word32 -> T a -> CodeGenFunction r a
index i rb = do
   k <- flip A.irem (length rb) =<< A.add (current rb) i
   Memory.load =<< LLVM.getElementPtr (buffer rb) (k, ())

{- |
Fetch the oldest value in the ring buffer.
For the result of @track initial time@
this is equivalent to @index time@ but more efficient.
-}
oldest ::
   (Memory.C a) =>
   T a -> CodeGenFunction r a
oldest rb =
   Memory.load =<< LLVM.getElementPtr (buffer rb) (oldest_ rb, ())


{- |
@track initial time@ tracks the last @time@ sample values
including the current one.
The values before the actual input data are filled with @initial@.
The values can be accessed using 'index' with indices
ranging from 0 to @time@.

The @time@ parameter must be non-negative.

The initial value is also needed for determining the ring buffer element type.
-}
track ::
   (Storable a, Class.MakeValueTuple a,
    Class.ValueTuple a ~ al, Memory.C al) =>
   Param.T p a -> Param.T p Int -> CausalP.T p al (T al)
track initial time =
   Param.with initial $ \getInitial valueInitial ->
   Param.with (Param.word32 time) $ \getTime valueTime ->
       CausalP.Cons
          (trackNext valueTime)
          (\(x, size) -> trackStart valueTime (valueInitial x, size))
          trackStop
          (trackCreate getInitial getTime)
          trackDelete

{- |
Initialize with zero without the need of a Haskell zero value.

We cannot get rid of the type 'a' so easily,
because we need its Storable instance
for allocating the buffer on the Haskell side.
-}
trackConst ::
   (Memory.C al) =>
   al -> Param.T p Int -> CausalP.T p al (T al)
trackConst initial time =
   Param.with (Param.word32 time) $ \getTime valueTime ->
       CausalP.Cons
          (trackNext valueTime)
          (\size -> trackStart valueTime (initial, size))
          trackStop
          (trackConstCreate getTime)
          trackDelete

trackConstCreate ::
   (p -> t) ->
   p ->
   IO ((), t)
trackConstCreate getTime p =
   return ((), getTime p)


trackNext ::
   (Memory.C al, Memory.Struct al ~ am) =>
   (tl -> Value Word32) ->
   (tl, Value (Ptr am)) ->
   al -> Value Word32 ->
   Maybe.T r z (T al, Value Word32)
trackNext valueTime (size,ptr) a remain0 = Maybe.lift $ do
   Memory.store a =<< LLVM.getElementPtr ptr (remain0, ())
   cont <- A.cmp LLVM.CmpGT remain0 A.zero
   let size0 = valueTime size
   remain1 <- C.ifThenSelect cont size0 (A.dec remain0)
   size1 <- A.inc size0
   return (Cons ptr size1 remain0 remain1, remain1)

trackStart ::
   (Memory.C al, Memory.Struct al ~ am) =>
   (tl -> Value Word32) ->
   (al, tl) ->
   CodeGenFunction r ((tl, Value (Ptr am)), Value Word32)
trackStart valueTime (initial, size) = do
   let size0 = valueTime size
   size1 <- A.inc size0
   ptr <- LLVM.arrayMalloc size1
   -- cf. LLVM.Storable.Signal.fill
   C.arrayLoop size1 ptr () $ \ ptri () ->
      Memory.store initial ptri
   return ((size,ptr), size0)

trackStop ::
   (LLVM.IsType am) =>
   (tl, Value (Ptr am)) ->
   Value Word32 ->
   CodeGenFunction r ()
trackStop (_size,ptr) _remain = LLVM.free ptr

trackCreate ::
   (Class.MakeValueTuple a, Class.ValueTuple a ~ al,
    Memory.C al, Memory.Struct al ~ am) =>
   (p -> a) ->
   (p -> t) ->
   p ->
   IO ((), (a, t))
trackCreate getInitial getTime p =
   return ((), (getInitial p, getTime p))

trackDelete :: () -> IO ()
trackDelete () = return ()