module Synthesizer.LLVM.CausalParameterized.RingBufferForward (
T, track, trackSkip, trackSkipHold,
index,
) where
import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate
as CausalPrivP
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigP
import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*))
import Synthesizer.LLVM.RingBuffer (MemoryPtr)
import qualified LLVM.DSL.Parameter as Param
import qualified LLVM.Extra.MaybeContinuation as MaybeCont
import qualified LLVM.Extra.Maybe 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 Control.Arrow ((<<<))
import Control.Applicative (pure)
import Data.Tuple.HT (mapSnd)
import Data.Word (Word)
import Prelude hiding (length)
data T a =
Cons {
buffer :: Value (MemoryPtr a),
length :: Value Word,
current :: Value Word
}
index :: (Memory.C a) => Value Word -> 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, ())
track :: (Memory.C a) => Param.T p Int -> SigP.T p a -> SigP.T p (T a)
track time input = trackSkip time input $* 1
trackSkip ::
(Memory.C a) =>
Param.T p Int -> SigP.T p a -> CausalP.T p (Value Word) (T a)
trackSkip time (SigP.Cons next alloca start stop create delete) =
Param.withValue (Param.wordInt time) $ \getTime valueTime ->
CausalPrivP.Cons
(trackNext next valueTime)
alloca
(trackStart start valueTime)
(trackStop stop)
(trackCreate create getTime)
(trackDelete delete)
trackSkipHold, trackSkipHold_ ::
(Memory.C a) =>
Param.T p Int -> SigP.T p a ->
CausalP.T p (Value Word) ((Value Bool, Value Word), T a)
trackSkipHold time xs =
(CausalP.zipWithSimple
(\b ((c,x), buf) -> do
y <- C.select b x A.zero
return ((c, y), buf))
$< (CausalP.delay1 (pure False) $* SigP.constant (pure True)))
<<<
trackSkipHold_ time xs
trackSkipHold_ time (SigP.Cons next alloca start stop create delete) =
(Param.withValue (Param.wordInt time) $ \getTime valueTime ->
CausalPrivP.Cons
(trackNextHold next valueTime)
alloca
(trackStartHold start valueTime)
(trackStopHold stop)
(trackCreate create getTime)
(trackDelete delete))
trackNext ::
(Memory.C al, Tuple.Phi z,
Tuple.Phi state, Tuple.Undefined state) =>
(forall z0. (Tuple.Phi z0) =>
context -> local -> state -> MaybeCont.T r z0 (al, state)) ->
(tl -> Value Word) ->
(context, (tl, Value (MemoryPtr al))) -> local ->
Value Word ->
(Value Word, (state, Value Word)) ->
MaybeCont.T r z (T al, (Value Word, (state, Value Word)))
trackNext next valueTime (context, (size,ptr)) local n1 (n0, statePos) = do
let size0 = valueTime size
(state3, pos3) <-
MaybeCont.fromMaybe $ fmap snd $
MaybeCont.fixedLengthLoop n0 statePos $ \(state0, pos0) -> do
(a, state1) <- next context local state0
MaybeCont.lift $
fmap ((,) state1) $ storeNext (size0,ptr) a pos0
return (Cons ptr size0 pos3, (n1, (state3, pos3)))
trackStart ::
(LLVM.IsSized am, Tuple.Phi state, Tuple.Undefined state) =>
(param -> CodeGenFunction r (context, state)) ->
(tl -> Value Word) ->
(param, tl) ->
CodeGenFunction r
((context, (tl, Value (LLVM.Ptr am))),
(Value Word, (state, Value Word)))
trackStart start valueTime (param, size) = do
(context, state) <- start param
let size0 = valueTime size
ptr <- LLVM.arrayMalloc size0
return ((context, (size,ptr)), (size0, (state, A.zero)))
trackStop ::
(LLVM.IsType am) =>
(context -> state -> CodeGenFunction r ()) ->
(context, (tl, Value (LLVM.Ptr am))) ->
(Value Word, (state, Value Word)) ->
CodeGenFunction r ()
trackStop stop (context, (_size,ptr)) (_n, (state, _remain)) = do
LLVM.free ptr
stop context state
trackNextHold ::
(Memory.C al, Tuple.Phi z,
Tuple.Phi state, Tuple.Undefined state) =>
(forall z0. (Tuple.Phi z0) =>
context -> local -> state -> MaybeCont.T r z0 (al, state)) ->
(tl -> Value Word) ->
(context, (tl, Value (MemoryPtr al))) -> local ->
Value Word ->
(Value Word, (Maybe.T state, Value Word)) ->
MaybeCont.T r z
(((Value Bool, Value Word), T al),
(Value Word, (Maybe.T state, Value Word)))
trackNextHold
next valueTime (context, (size,ptr)) local nNext (n0, (mstate0, pos0)) =
MaybeCont.lift $ do
let size0 = valueTime size
(n3, (pos3, state3)) <-
Maybe.run mstate0
(return (n0, (pos0, mstate0)))
(\state0 ->
Maybe.loopWithExit (n0, (state0, pos0))
(\(n1, (state1, pos1)) -> do
cont <- A.cmp LLVM.CmpGT n1 A.zero
fmap (mapSnd ((,) n1 . (,) pos1)) $
C.ifThen cont
(Maybe.nothing, Maybe.just state1)
(do aState <-
MaybeCont.toMaybe $ next context local state1
return (aState, fmap snd aState)))
(\((a,state), (n1, (pos1, _mstate))) -> do
pos2 <- storeNext (size0,ptr) a pos1
n2 <- A.dec n1
return (n2, (state, pos2))))
skipped <- A.sub n0 n3
return (((Maybe.isJust state3, skipped), Cons ptr size0 pos3),
(nNext, (state3, pos3)))
storeNext ::
(Memory.C al) =>
(Value Word, Value (MemoryPtr al)) ->
al -> Value Word -> CodeGenFunction r (Value Word)
storeNext (size0,ptr) a pos0 = do
Memory.store a =<< LLVM.getElementPtr ptr (pos0, ())
pos1 <- A.inc pos0
cont <- A.cmp LLVM.CmpLT pos1 size0
C.select cont pos1 A.zero
trackStartHold ::
(LLVM.IsSized am,
Tuple.Phi state, Tuple.Undefined state) =>
(param -> CodeGenFunction r (context, state)) ->
(tl -> Value Word) ->
(param, tl) ->
CodeGenFunction r
((context, (tl, Value (LLVM.Ptr am))),
(Value Word, (Maybe.T state, Value Word)))
trackStartHold start valueTime (param, size) = do
(context, state) <- start param
let size0 = valueTime size
ptr <- LLVM.arrayMalloc size0
return ((context, (size,ptr)), (size0, (Maybe.just state, A.zero)))
trackStopHold ::
(LLVM.IsType am) =>
(context -> state -> CodeGenFunction r ()) ->
(context, (tl, Value (LLVM.Ptr am))) ->
(Value Word, (Maybe.T state, Value Word)) ->
CodeGenFunction r ()
trackStopHold stop (context, (_size,ptr)) (_n, (state, _remain)) = do
LLVM.free ptr
Maybe.for state $ stop context
trackCreate ::
(p -> IO (ioContext, param)) ->
(p -> t) ->
p ->
IO (ioContext, (param, t))
trackCreate create getTime p = do
(context, param) <- create p
return (context, (param, getTime p))
trackDelete :: (ioContext -> IO ()) -> ioContext -> IO ()
trackDelete = id