RingBuffer.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Synthesizer.LLVM.RingBuffer (
   T, track,
   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 qualified Synthesizer.LLVM.Alloc as Alloc
import Foreign.Ptr (Ptr, )

import Prelude hiding (length, )


data T ap =
   Cons {
      buffer :: Value (Ptr ap),
      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 ::
   (Memory.C a) =>
   Value Word32 -> T (Memory.Struct 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 (Memory.Struct 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 (Memory.Struct al))
track initial time =
   let time32 = fmap (fromIntegral :: Int -> Word32) time in
   CausalP.Cons
      (\(size,ptr) a remain0 -> Maybe.lift $ do
         Memory.store a =<< LLVM.getElementPtr ptr (remain0, ())
         cont <- A.cmp LLVM.CmpGT remain0 (LLVM.value LLVM.zero)
         remain1 <-
            C.ifThenSelect cont (Param.value time32 size)
               (A.dec remain0)
         size1 <- A.inc (Param.value time32 size)
         return (Cons ptr size1 remain0 remain1, remain1))
      (\(x, (size,ptr)) -> do
         size1 <- A.inc (Param.value time32 size)
         -- cf. LLVM.Storable.Signal.fill
         C.arrayLoop size1 ptr () $ \ ptri () ->
            Memory.store (Param.value initial x) ptri >> return ()
         return size)
      (\p -> do
         let size = Param.get time p
             x = Param.get initial p
         {-
         We allocate one element more than necessary
         in order to simplify handling of delay time zero
         -}
         ptr <- Alloc.mallocArray (size+1)
         let param =
               (fromIntegral size :: Word32,
                Memory.castStorablePtr (ptrAsTypeOf ptr x))
         return ((size,ptr), (param, (x, param))))
      (\(size,ptr) -> Alloc.freeArray (size + 1) ptr)

ptrAsTypeOf :: Ptr a -> a -> Ptr a
ptrAsTypeOf p _ = p