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 qualified Synthesizer.LLVM.Parameter as Param
import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), )
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.Class as Class
import qualified LLVM.Core as LLVM
import LLVM.Util.Loop (Phi, )
import LLVM.Core (CodeGenFunction, Value, )
import Control.Arrow ((<<<), )
import Control.Applicative (pure, )
import Data.Tuple.HT (mapSnd, )
import Data.Word (Word32, )
import Foreign.Storable.Tuple ()
import Foreign.Ptr (Ptr, )
import Prelude hiding (length, )
data T a =
Cons {
buffer :: Value (Ptr (Memory.Struct a)),
length :: Value Word32,
current :: Value Word32
}
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, ())
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 Word32) (T a)
trackSkip time (SigP.Cons next alloca start stop create delete) =
Param.with (Param.word32 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 Word32) ((Value Bool, Value Word32), 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.with (Param.word32 time) $ \getTime valueTime ->
CausalPrivP.Cons
(trackNextHold next valueTime)
alloca
(trackStartHold start valueTime)
(trackStopHold stop)
(trackCreate create getTime)
(trackDelete delete))
trackNext ::
(Memory.C al, Memory.Struct al ~ am, Phi z,
Phi state, Class.Undefined state) =>
(forall z0. (Phi z0) =>
context -> local -> state -> MaybeCont.T r z0 (al, state)) ->
(tl -> Value Word32) ->
(context, (tl, Value (Ptr am))) -> local ->
Value Word32 ->
(Value Word32, (state, Value Word32)) ->
MaybeCont.T r z (T al, (Value Word32, (state, Value Word32)))
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,
Phi state, Class.Undefined state) =>
(param -> CodeGenFunction r (context, state)) ->
(tl -> Value Word32) ->
(param, tl) ->
CodeGenFunction r
((context, (tl, Value (Ptr am))),
(Value Word32, (state, Value Word32)))
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 (Ptr am))) ->
(Value Word32, (state, Value Word32)) ->
CodeGenFunction r ()
trackStop stop (context, (_size,ptr)) (_n, (state, _remain)) = do
LLVM.free ptr
stop context state
trackNextHold ::
(Memory.C al, Memory.Struct al ~ am, Phi z,
Phi state, Class.Undefined state) =>
(forall z0. (Phi z0) =>
context -> local -> state -> MaybeCont.T r z0 (al, state)) ->
(tl -> Value Word32) ->
(context, (tl, Value (Ptr am))) -> local ->
Value Word32 ->
(Value Word32, (Maybe.T state, Value Word32)) ->
MaybeCont.T r z
(((Value Bool, Value Word32), T al),
(Value Word32, (Maybe.T state, Value Word32)))
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, Memory.Struct al ~ am) =>
(Value Word32, Value (Ptr am)) ->
al -> Value Word32 -> CodeGenFunction r (Value Word32)
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,
Phi state, Class.Undefined state) =>
(param -> CodeGenFunction r (context, state)) ->
(tl -> Value Word32) ->
(param, tl) ->
CodeGenFunction r
((context, (tl, Value (Ptr am))),
(Value Word32, (Maybe.T state, Value Word32)))
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 (Ptr am))) ->
(Value Word32, (Maybe.T state, Value Word32)) ->
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