{-# LANGUAGE TypeFamilies #-}
module Synthesizer.LLVM.RingBuffer where

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.Tuple as Tuple

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

import Data.Word (Word)

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 {
      forall a. T a -> Value (MemoryPtr a)
buffer :: Value (MemoryPtr a),
      forall a. T a -> Value Word
length :: Value Word,
      forall a. T a -> Value Word
current :: Value Word,
      forall a. T a -> Value Word
oldest_ :: Value Word
   }

type MemoryPtr a = LLVM.Ptr (Memory.Struct a)

{- |
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 Word -> T a -> CodeGenFunction r a
index :: forall a r. C a => Value Word -> T a -> CodeGenFunction r a
index Value Word
i T a
rb = do
   Value Word
k <- (Value Word -> Value Word -> CodeGenFunction r (Value Word))
-> Value Word -> Value Word -> CodeGenFunction r (Value Word)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Value Word -> Value Word -> CodeGenFunction r (Value Word)
forall a r.
IsInteger a =>
Value a -> Value a -> CodeGenFunction r (Value a)
A.irem (T a -> Value Word
forall a. T a -> Value Word
length T a
rb) (Value Word -> CodeGenFunction r (Value Word))
-> CodeGenFunction r (Value Word) -> CodeGenFunction r (Value Word)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value Word -> Value Word -> CodeGenFunction r (Value Word)
forall a r. Additive a => a -> a -> CodeGenFunction r a
forall r.
Value Word -> Value Word -> CodeGenFunction r (Value Word)
A.add (T a -> Value Word
forall a. T a -> Value Word
current T a
rb) Value Word
i
   Value (Ptr (Struct a)) -> CodeGenFunction r a
forall llvmValue r.
C llvmValue =>
Value (Ptr (Struct llvmValue)) -> CodeGenFunction r llvmValue
forall r. Value (Ptr (Struct a)) -> CodeGenFunction r a
Memory.load (Value (Ptr (Struct a)) -> CodeGenFunction r a)
-> CodeGenFunction r (Value (Ptr (Struct a)))
-> CodeGenFunction r a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value (Ptr (Struct a))
-> (Value Word, ())
-> CodeGenFunction r (Value (Ptr (ElementPtrType (Struct a) ())))
forall a o i r.
(GetElementPtr o i, IsIndexArg a) =>
Value (Ptr o)
-> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))
LLVM.getElementPtr (T a -> Value (Ptr (Struct a))
forall a. T a -> Value (MemoryPtr a)
buffer T a
rb) (Value Word
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 :: forall a r. C a => T a -> CodeGenFunction r a
oldest T a
rb =
   Value (Ptr (Struct a)) -> CodeGenFunction r a
forall llvmValue r.
C llvmValue =>
Value (Ptr (Struct llvmValue)) -> CodeGenFunction r llvmValue
forall r. Value (Ptr (Struct a)) -> CodeGenFunction r a
Memory.load (Value (Ptr (Struct a)) -> CodeGenFunction r a)
-> CodeGenFunction r (Value (Ptr (Struct a)))
-> CodeGenFunction r a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value (Ptr (Struct a))
-> (Value Word, ())
-> CodeGenFunction r (Value (Ptr (ElementPtrType (Struct a) ())))
forall a o i r.
(GetElementPtr o i, IsIndexArg a) =>
Value (Ptr o)
-> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))
LLVM.getElementPtr (T a -> Value (Ptr (Struct a))
forall a. T a -> Value (MemoryPtr a)
buffer T a
rb) (T a -> Value Word
forall a. T a -> Value Word
oldest_ T a
rb, ())


trackConstCreate :: (p -> t) -> p -> IO ((), t)
trackConstCreate :: forall p t. (p -> t) -> p -> IO ((), t)
trackConstCreate p -> t
getTime p
p = ((), t) -> IO ((), t)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), p -> t
getTime p
p)


trackNext ::
   (Memory.C al) =>
   (tl -> Value Word) ->
   (tl, Value (MemoryPtr al)) -> () ->
   al -> Value Word ->
   Maybe.T r z (T al, Value Word)
trackNext :: forall al tl r z.
C al =>
(tl -> Value Word)
-> (tl, Value (MemoryPtr al))
-> ()
-> al
-> Value Word
-> T r z (T al, Value Word)
trackNext tl -> Value Word
valueTime (tl
size,Value (MemoryPtr al)
ptr) () al
a Value Word
remain0 = CodeGenFunction r (T al, Value Word) -> T r z (T al, Value Word)
forall r a z. CodeGenFunction r a -> T r z a
Maybe.lift (CodeGenFunction r (T al, Value Word) -> T r z (T al, Value Word))
-> CodeGenFunction r (T al, Value Word) -> T r z (T al, Value Word)
forall a b. (a -> b) -> a -> b
$ do
   al -> Value (MemoryPtr al) -> CodeGenFunction r ()
forall r. al -> Value (MemoryPtr al) -> CodeGenFunction r ()
forall llvmValue r.
C llvmValue =>
llvmValue -> Value (Ptr (Struct llvmValue)) -> CodeGenFunction r ()
Memory.store al
a (Value (MemoryPtr al) -> CodeGenFunction r ())
-> CodeGenFunction r (Value (MemoryPtr al)) -> CodeGenFunction r ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value (MemoryPtr al)
-> (Value Word, ())
-> CodeGenFunction r (Value (Ptr (ElementPtrType (Struct al) ())))
forall a o i r.
(GetElementPtr o i, IsIndexArg a) =>
Value (Ptr o)
-> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))
LLVM.getElementPtr Value (MemoryPtr al)
ptr (Value Word
remain0, ())
   Value Bool
cont <- CmpPredicate
-> Value Word
-> Value Word
-> CodeGenFunction r (CmpResult (Value Word))
forall r.
CmpPredicate
-> Value Word
-> Value Word
-> CodeGenFunction r (CmpResult (Value Word))
forall a r.
Comparison a =>
CmpPredicate -> a -> a -> CodeGenFunction r (CmpResult a)
A.cmp CmpPredicate
LLVM.CmpGT Value Word
remain0 Value Word
forall a. Additive a => a
A.zero
   let size0 :: Value Word
size0 = tl -> Value Word
valueTime tl
size
   Value Word
remain1 <- Value Bool
-> Value Word
-> CodeGenFunction r (Value Word)
-> CodeGenFunction r (Value Word)
forall a r.
Select a =>
Value Bool -> a -> CodeGenFunction r a -> CodeGenFunction r a
C.ifThenSelect Value Bool
cont Value Word
size0 (Value Word -> CodeGenFunction r (Value Word)
forall a r.
(IsArithmetic a, IsConst a, Num a) =>
Value a -> CodeGenFunction r (Value a)
A.dec Value Word
remain0)
   Value Word
size1 <- Value Word -> CodeGenFunction r (Value Word)
forall a r.
(IsArithmetic a, IsConst a, Num a) =>
Value a -> CodeGenFunction r (Value a)
A.inc Value Word
size0
   (T al, Value Word) -> CodeGenFunction r (T al, Value Word)
forall a. a -> CodeGenFunction r a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value (MemoryPtr al)
-> Value Word -> Value Word -> Value Word -> T al
forall a.
Value (MemoryPtr a)
-> Value Word -> Value Word -> Value Word -> T a
Cons Value (MemoryPtr al)
ptr Value Word
size1 Value Word
remain0 Value Word
remain1, Value Word
remain1)

trackStart ::
   (Memory.C al) =>
   (tl -> Value Word) ->
   (al, tl) ->
   CodeGenFunction r ((tl, Value (MemoryPtr al)), Value Word)
trackStart :: forall al tl r.
C al =>
(tl -> Value Word)
-> (al, tl)
-> CodeGenFunction r ((tl, Value (MemoryPtr al)), Value Word)
trackStart tl -> Value Word
valueTime (al
initial, tl
size) = do
   let size0 :: Value Word
size0 = tl -> Value Word
valueTime tl
size
   Value Word
size1 <- Value Word -> CodeGenFunction r (Value Word)
forall a r.
(IsArithmetic a, IsConst a, Num a) =>
Value a -> CodeGenFunction r (Value a)
A.inc Value Word
size0
   Value (MemoryPtr al)
ptr <- Value Word -> CodeGenFunction r (Value (MemoryPtr al))
forall a r s.
(IsSized a, AllocArg s) =>
s -> CodeGenFunction r (Value (Ptr a))
LLVM.arrayMalloc Value Word
size1
   -- cf. LLVM.Storable.Signal.fill
   Value Word
-> Value (MemoryPtr al)
-> ()
-> (Value (MemoryPtr al) -> () -> CodeGenFunction r ())
-> CodeGenFunction r ()
forall a b i r.
(Phi a, IsType b, Num i, IsConst i, IsInteger i, CmpRet i,
 IsPrimitive i) =>
Value i
-> Value (Ptr b)
-> a
-> (Value (Ptr b) -> a -> CodeGenFunction r a)
-> CodeGenFunction r a
C.arrayLoop Value Word
size1 Value (MemoryPtr al)
ptr () ((Value (MemoryPtr al) -> () -> CodeGenFunction r ())
 -> CodeGenFunction r ())
-> (Value (MemoryPtr al) -> () -> CodeGenFunction r ())
-> CodeGenFunction r ()
forall a b. (a -> b) -> a -> b
$ \ Value (MemoryPtr al)
ptri () ->
      al -> Value (MemoryPtr al) -> CodeGenFunction r ()
forall r. al -> Value (MemoryPtr al) -> CodeGenFunction r ()
forall llvmValue r.
C llvmValue =>
llvmValue -> Value (Ptr (Struct llvmValue)) -> CodeGenFunction r ()
Memory.store al
initial Value (MemoryPtr al)
ptri
   ((tl, Value (MemoryPtr al)), Value Word)
-> CodeGenFunction r ((tl, Value (MemoryPtr al)), Value Word)
forall a. a -> CodeGenFunction r a
forall (m :: * -> *) a. Monad m => a -> m a
return ((tl
size,Value (MemoryPtr al)
ptr), Value Word
size0)

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

trackCreate ::
   (Tuple.Value a) =>
   (p -> a) ->
   (p -> t) ->
   p ->
   IO ((), (a, t))
trackCreate :: forall a p t.
Value a =>
(p -> a) -> (p -> t) -> p -> IO ((), (a, t))
trackCreate p -> a
getInitial p -> t
getTime p
p =
   ((), (a, t)) -> IO ((), (a, t))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), (p -> a
getInitial p
p, p -> t
getTime p
p))

trackDelete :: () -> IO ()
trackDelete :: () -> IO ()
trackDelete () = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()