{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.Causal.RingBufferForward (
T, track, trackSkip, trackSkipHold,
index, mapIndex,
) where
import qualified Synthesizer.LLVM.Causal.Private as CausalPriv
import qualified Synthesizer.LLVM.Causal.Process as Causal
import qualified Synthesizer.LLVM.Generator.Private as Sig
import Synthesizer.LLVM.RingBuffer (MemoryPtr)
import Synthesizer.LLVM.Causal.Process (($*#))
import Synthesizer.Causal.Class (($<), ($*))
import qualified LLVM.DSL.Expression as Expr
import LLVM.DSL.Expression (Exp)
import qualified LLVM.Extra.Multi.Value as MultiValue
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 qualified Control.Arrow as Arrow
import Control.Arrow ((<<<), (<<^))
import Data.Tuple.HT (mapSnd, mapPair)
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) => MultiValue.T Word -> T a -> CodeGenFunction r a
index (MultiValue.Cons i) rb = do
k <- flip A.irem (length rb) =<< A.add (current rb) i
Memory.load =<< LLVM.getElementPtr (buffer rb) (k, ())
mapIndex :: (Memory.C a) => Exp Word -> Causal.T (T a) a
mapIndex k = CausalPriv.map (\buf -> flip index buf =<< Expr.unExp k)
track :: (Memory.C a) => Exp Word -> Sig.T a -> Sig.T (T a)
track time input = trackSkip time input $* 1
trackSkip ::
(Memory.C a) =>
Exp Word -> Sig.T a -> Causal.T (MultiValue.T Word) (T a)
trackSkip time (Sig.Cons next start stop) =
CausalPriv.Cons
(trackNext next)
(trackStart start time)
(trackStop stop)
<<^
(\(MultiValue.Cons skip) -> skip)
trackSkipHold ::
(Memory.C a) =>
Exp Word -> Sig.T a ->
Causal.T (MultiValue.T Word) ((MultiValue.T Bool, MultiValue.T Word), T a)
trackSkipHold time xs =
Arrow.first
(Arrow.second clearFirst <<^ mapPair (MultiValue.Cons, MultiValue.Cons))
<<<
trackSkipHold_ time xs
<<^
(\(MultiValue.Cons skip) -> skip)
clearFirst ::
(MultiValue.PseudoRing a, MultiValue.Real a,
MultiValue.IntegerConstant a, MultiValue.Select a) =>
Causal.MV a a
clearFirst =
Causal.zipWith (\b x -> Expr.select b x 0)
$< (Causal.delay1 Expr.false $*# True)
trackSkipHold_ ::
(Memory.C a) =>
Exp Word -> Sig.T a ->
Causal.T (Value Word) ((Value Bool, Value Word), T a)
trackSkipHold_ time (Sig.Cons next start stop) =
CausalPriv.Cons
(trackNextHold next)
(trackStartHold start time)
(trackStopHold stop)
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)) ->
(context, (Value Word, Value (MemoryPtr al))) -> local ->
Value Word ->
(Value Word, (state, Value Word)) ->
MaybeCont.T r z (T al, (Value Word, (state, Value Word)))
trackNext next (context, (size0,ptr)) local n1 (n0, statePos) = do
(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) =>
CodeGenFunction r (context, state) ->
Exp Word ->
CodeGenFunction r
((context, (Value Word, Value (LLVM.Ptr am))),
(Value Word, (state, Value Word)))
trackStart start size = do
(context, state) <- start
~(MultiValue.Cons size0) <- Expr.unExp size
ptr <- LLVM.arrayMalloc size0
return ((context, (size0,ptr)), (size0, (state, A.zero)))
trackStop ::
(LLVM.IsType am) =>
(context -> CodeGenFunction r ()) ->
(context, (tl, Value (LLVM.Ptr am))) ->
CodeGenFunction r ()
trackStop stop (context, (_size,ptr)) = do
LLVM.free ptr
stop context
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)) ->
(context, (Value Word, 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 (context, (size0,ptr)) local nNext (n0, (mstate0, pos0)) =
MaybeCont.lift $ do
(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) =>
CodeGenFunction r (context, state) ->
Exp Word ->
CodeGenFunction r
((context, (Value Word, Value (LLVM.Ptr am))),
(Value Word, (Maybe.T state, Value Word)))
trackStartHold start size = do
(context, state) <- start
~(MultiValue.Cons size0) <- Expr.unExp size
ptr <- LLVM.arrayMalloc size0
return ((context, (size0,ptr)), (size0, (Maybe.just state, A.zero)))
trackStopHold ::
(LLVM.IsType am) =>
(context -> CodeGenFunction r ()) ->
(context, (Value Word, Value (LLVM.Ptr am))) ->
CodeGenFunction r ()
trackStopHold stop (context, (_size,ptr)) = do
LLVM.free ptr
stop context