{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Synthesizer.LLVM.Parameterized.Signal (
   T(Cons), simple, map, mapSimple, zipWith, zipWithSimple, iterate,
   module Synthesizer.LLVM.Parameterized.Signal
   ) where

import Synthesizer.LLVM.Parameterized.SignalPrivate
import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as Causal
import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.ConstantPiece as Const

import qualified Synthesizer.LLVM.Random as Rnd
import qualified Synthesizer.LLVM.Wave as Wave
import qualified Synthesizer.LLVM.Frame as Frame
import qualified Synthesizer.LLVM.Execution as Exec

import qualified LLVM.Extra.MaybeContinuation as Maybe
import qualified LLVM.Extra.ForeignPtr as ForeignPtr
import qualified LLVM.Extra.Memory as Memory
import LLVM.Extra.Control (whileLoop, ifThen, )

import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt
import qualified Data.StorableVector.Lazy.Pattern as SVP
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB

import qualified Data.EventList.Relative.BodyTime as EventList
import qualified Numeric.NonNegative.Chunky as Chunky
import qualified Numeric.NonNegative.Wrapper as NonNeg

import qualified Synthesizer.LLVM.Frame.Stereo as Stereo

import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.ScalarOrVector as SoV
import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )
import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, )

import LLVM.Core as LLVM
import qualified LLVM.Util.Loop as Loop
import qualified Types.Data.Num as TypeNum

import Control.Monad.HT ((<=<), )
import Control.Monad (liftM2, liftM3, when, )
import Control.Arrow ((^<<), )
import Control.Applicative (liftA2, )
import Control.Functor.HT (void, )

import qualified Algebra.Transcendental as Trans
import qualified Algebra.RealField as RealField
import qualified Algebra.Algebraic as Algebraic
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive

import Data.Word (Word8, Word32, )
import Data.Int (Int32, )
import Foreign.Storable.Tuple ()
import Foreign.Storable (Storable, )
import Foreign.Marshal.Array (advancePtr, )
import qualified Synthesizer.LLVM.Alloc as Alloc
import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, )
import Foreign.Ptr (FunPtr, nullPtr, )
import Control.Exception (bracket, )
import qualified System.Unsafe as Unsafe

import qualified Synthesizer.LLVM.Debug.Storable as DebugSt
import qualified Synthesizer.LLVM.Debug.Counter as Counter

import NumericPrelude.Numeric
import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )

-- for debugMain
import qualified Control.Monad.Trans.Reader as R


infixl 0 $#

($#) :: (Param.T p a -> b) -> (a -> b)
($#) f a = f (return a)


mapAccum ::
   (Storable pnh, MakeValueTuple pnh, ValueTuple pnh ~ pnl, Memory.C pnl,
    Storable psh, MakeValueTuple psh, ValueTuple psh ~ psl, Memory.C psl,
    Memory.C s) =>
   (forall r. pnl -> a -> s -> CodeGenFunction r (b,s)) ->
   (forall r. psl -> CodeGenFunction r s) ->
   Param.T p pnh ->
   Param.T p psh ->
   T p a -> T p b
mapAccum f startS selectParamF selectParamS
      (Cons next start createIOContext deleteIOContext) =
   Cons
      (\(parameterF, parameter) (sa0,ss0) -> do
         (a,sa1) <- next parameter sa0
         (b,ss1) <- Maybe.lift $ f (Param.value selectParamF parameterF) a ss0
         return (b, (sa1,ss1)))
      (\(parameterF, parameter) ->
         liftM2 (,) (start parameter) (startS (Param.value selectParamS parameterF)))
      (\p -> do
         (ioContext, (nextParam, startParam)) <- createIOContext p
         return (ioContext, ((Param.get selectParamF p, nextParam),
                             (Param.get selectParamS p, startParam))))
      deleteIOContext


zip :: T p a -> T p b -> T p (a,b)
zip = liftA2 (,)


-- * timeline edit

{- |
@tail empty@ generates the empty signal.
-}
tail ::
   T p a -> T p a
tail (Cons next start createIOContext deleteIOContext) = Cons
   next
   (\(nextParameter, startParameter) -> do
      s0 <- start startParameter
      Maybe.resolve (next nextParameter s0)
         (return s0)
         (\(_a,s1) -> return s1))
   (\p -> do
      (ioContext, (nextParam, startParam)) <- createIOContext p
      return (ioContext, (nextParam, (nextParam, startParam))))
   deleteIOContext

drop ::
   Param.T p Int ->
   T p a -> T p a
drop n (Cons next start createIOContext deleteIOContext) =
      let n32 = fmap (fromIntegral :: Int -> Word32) n in Cons
   next
   (\(nextParameter, i0, startParameter) -> do
      s0 <- start startParameter
      (_, _, s3) <-
         whileLoop (valueOf True, Param.value n32 i0, s0)
            (\(cont,i1,_s1) ->
               A.and cont =<<
                  A.cmp CmpGT i1 (value LLVM.zero))
            (\(_cont,i1,s1) -> do
               (cont, s2) <-
                  Maybe.resolve (next nextParameter s1)
                     (return (valueOf False, s1))
                     (\(_a,s) -> return (valueOf True, s))
               i2 <- A.dec i1
               return (cont, i2, s2))
      return s3)
   (\p -> do
      (ioContext, (nextParam, startParam)) <- createIOContext p
      return (ioContext, (nextParam,
         (nextParam, Param.get n32 p, startParam))))
   deleteIOContext

{- |
Appending many signals is inefficient,
since in cascadingly appended signals the parts are counted in an unary way.
Concatenating infinitely many signals is impossible.
If you want to concatenate a lot of signals,
please render them to lazy storable vectors first.
-}
{-
We might save a little space by using a union
for the states of the first and the second signal generator.
-}
append ::
   (Loop.Phi a, Undefined a) =>
   T p a -> T p a -> T p a
append
      (Cons nextA startA createIOContextA deleteIOContextA)
      (Cons nextB startB createIOContextB deleteIOContextB) =
   Cons
      (\(parameterA, parameterB) (firstPart,(sa0,sb0)) ->
            Maybe.fromBool $ do
         (contA, (a,sa1)) <-
            ifThen firstPart (valueOf False, (undefTuple,sa0))
               (Maybe.toBool $ nextA parameterA sa0)
         secondPart <- inv contA
         (contB, (b,sb1)) <-
            ifThen secondPart (valueOf True, (a,sb0))
               (Maybe.toBool $ nextB parameterB sb0)
         return (contB, (b, (contA, (sa1,sb1)))))
      (\(parameterA, parameterB) ->
         fmap ((,) (valueOf True)) $
         liftM2 (,)
            (startA parameterA)
            (startB parameterB))
      (\p -> do
         (ca,(nextParamA,startParamA)) <- createIOContextA p
         (cb,(nextParamB,startParamB)) <- createIOContextB p
         return ((ca,cb),
            ((nextParamA, nextParamB),
             (startParamA, startParamB))))
      (\(ca,cb) ->
         deleteIOContextA ca >>
         deleteIOContextB cb)


-- * signal modifiers

{- |
Stretch signal in time by a certain factor.

This can be used for doing expensive computations
of filter parameters at a lower rate.
Alternatively, we could provide an adaptive @map@
that recomputes output values only if the input value changes,
or if the input value differs from the last processed one by a certain amount.
-}
interpolateConstant ::
   (Memory.C a,
    Ring.C b,
    IsFloating b, CmpRet b, CmpResult b ~ Bool,
    Storable b, MakeValueTuple b, ValueTuple b ~ (Value b), IsConst b,
    Memory.FirstClass b, IsSized b, IsSized (Memory.Stored b)) =>
   Param.T p b -> T p a -> T p a
interpolateConstant k
      (Cons next start createIOContext deleteIOContext) =
   Cons
      (\(kl,parameter) yState0 -> do
         ((y1,state1), ss1) <-
            Maybe.fromBool $
            whileLoop
               (valueOf True, yState0)
               (\(cont1, (_, ss1)) ->
                  and cont1 =<< A.fcmp FPOLE ss1 (value LLVM.zero))
               (\(_,((_,state01), ss1)) ->
                  Maybe.toBool $ liftM2 (,)
                     (next parameter state01)
                     (Maybe.lift $ A.add ss1 (Param.value k kl)))

         ss2 <- Maybe.lift $ A.sub ss1 (valueOf Ring.one)
         return (y1, ((y1,state1),ss2)))

{- using this initialization code we would not need undefined values
      (do sa <- start
          (a,_) <- next sa
          return (sa, a, valueOf 0))
-}
      (fmap (\sa -> ((undefTuple, sa), value LLVM.zero)) . start)
      (\p -> do
         (ioContext, (nextParam, startParam)) <- createIOContext p
         return (ioContext, ((Param.get k p, nextParam), startParam)))
      deleteIOContext



mix ::
   (A.Additive a) =>
   T p a -> T p a -> T p a
mix =
   zipWithSimple Frame.mix


envelope ::
   (A.PseudoRing a) =>
   T p a -> T p a -> T p a
envelope =
   zipWithSimple Frame.amplifyMono

envelopeStereo ::
   (A.PseudoRing a) =>
   T p a -> T p (Stereo.T a) -> T p (Stereo.T a)
envelopeStereo =
   zipWithSimple Frame.amplifyStereo

amplify ::
   (A.PseudoRing al, Storable a,
    MakeValueTuple a, ValueTuple a ~ al, Memory.C al) =>
   Param.T p a -> T p al -> T p al
amplify =
   map Frame.amplifyMono

amplifyStereo ::
   (A.PseudoRing al, Storable a,
    MakeValueTuple a, ValueTuple a ~ al, Memory.C al) =>
   Param.T p a -> T p (Stereo.T al) -> T p (Stereo.T al)
amplifyStereo =
   map Frame.amplifyStereo


-- * signal generators

constant ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ al,
    Memory.C al) =>
   Param.T p a -> T p al
constant x =
   simple
      (\pl () -> return (pl, ()))
      return
      x
      (return ())


exponentialCore ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ al,
    Memory.C al, A.PseudoRing al) =>
   Param.T p a -> Param.T p a -> T p al
exponentialCore =
   iterate A.mul

exponential2 ::
   (Trans.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a),
    Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a),
    IsArithmetic a, IsConst a) =>
   Param.T p a -> Param.T p a -> T p (Value a)
exponential2 halfLife =
   exponentialCore (0.5 ** recip halfLife)


exponentialBoundedCore ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ al,
    Memory.C al, A.PseudoRing al, A.Real al) =>
   Param.T p a -> Param.T p a -> Param.T p a ->
   T p al
exponentialBoundedCore bound decay =
   iterate
      (\(b,k) y -> A.max b =<< A.mul k y)
      (liftA2 (,) bound decay)

{- |
Exponential curve that remains at the bound value
if it would fall below otherwise.
This way you can avoid extremal values, e.g. denormalized ones.
The initial value and the bound value must be positive.
-}
exponentialBounded2 ::
   (Trans.C a, Storable a, MakeValueTuple a, ValueTuple a ~ (Value a),
    Memory.FirstClass a, IsSized a, IsSized (Memory.Stored a),
    SoV.Real a, IsConst a) =>
   Param.T p a -> Param.T p a -> Param.T p a ->
   T p (Value a)
exponentialBounded2 bound halfLife =
   exponentialBoundedCore bound (0.5 ** recip halfLife)


osciCore ::
   (Storable t, MakeValueTuple t, ValueTuple t ~ tl,
    Memory.C tl, A.Fraction tl) =>
   Param.T p t -> Param.T p t -> T p tl
osciCore phase freq =
   iterate A.incPhase freq phase

osci ::
   (Storable t, MakeValueTuple t, ValueTuple t ~ tl,
    Storable c, MakeValueTuple c, ValueTuple c ~ cl,
    Memory.C cl,
    Memory.C tl, A.Fraction tl, A.IntegerConstant tl) =>
   (forall r. cl -> tl -> CodeGenFunction r y) ->
   Param.T p c ->
   Param.T p t -> Param.T p t -> T p y
osci wave waveParam phase freq =
   map wave waveParam $
   osciCore phase freq

osciSimple ::
   (Storable t, MakeValueTuple t, ValueTuple t ~ tl,
    Memory.C tl, A.Fraction tl, A.IntegerConstant tl) =>
   (forall r. tl -> CodeGenFunction r y) ->
   Param.T p t -> Param.T p t -> T p y
osciSimple wave =
   osci (const wave) (return ())

osciSaw ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ al,
    Memory.C al, A.PseudoRing al, A.Fraction al, A.IntegerConstant al) =>
   Param.T p a -> Param.T p a -> T p al
osciSaw =
   osciSimple Wave.saw



rampCore ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ al,
    Memory.C al, A.Additive al, A.IntegerConstant al) =>
   Param.T p a -> Param.T p a -> T p al
rampCore = iterate A.add

parabolaCore ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ al,
    Memory.C al, A.Additive al, A.IntegerConstant al) =>
   Param.T p a -> Param.T p a -> Param.T p a -> T p al
parabolaCore d2 d1 start =
   Causal.apply (Causal.integrate start) $
   rampCore d2 d1



rampInf, rampSlope,
 parabolaFadeInInf, parabolaFadeOutInf ::
   (Field.C a, Storable a, MakeValueTuple a, ValueTuple a ~ al,
    Memory.C al, A.Additive al, A.IntegerConstant al) =>
   Param.T p a -> T p al
rampSlope slope  =  rampCore slope Additive.zero
rampInf dur  =  rampSlope (recip dur)

{-
t*(2-t) = 1 - (t-1)^2

(t+d)*(2-t-d) - t*(2-t)
   = d*(2-t) - d*t - d^2
   = 2*d*(1-t) - d^2
   = d*(2*(1-t) - d)

2*d*(1-t-d) + d^2  -  (2*d*(1-t) + d^2)
   = -2*d^2
-}
parabolaFadeInInf dur =
   parabolaCore
      (fmap (\d -> -2*d*d)  $ recip dur)
      (fmap (\d -> d*(2-d)) $ recip dur)
      Additive.zero

{-
1-t^2
-}
parabolaFadeOutInf dur =
   parabolaCore
      (fmap (\d -> -2*d*d) $ recip dur)
      (fmap (\d ->   -d*d) $ recip dur)
      one

ramp,
 parabolaFadeIn, parabolaFadeOut,
 parabolaFadeInMap, parabolaFadeOutMap ::
   (RealField.C a, Storable a, MakeValueTuple a, ValueTuple a ~ al,
    Memory.C al, A.PseudoRing al, A.IntegerConstant al) =>
   Param.T p a -> T p al

ramp dur =
   Causal.apply (Causal.take (fmap round dur)) $
   rampInf dur

parabolaFadeIn dur =
   Causal.apply (Causal.take (fmap round dur)) $
   parabolaFadeInInf dur

parabolaFadeOut dur =
   Causal.apply (Causal.take (fmap round dur)) $
   parabolaFadeOutInf dur

parabolaFadeInMap dur =
   -- t*(2-t)
   Causal.apply (Causal.mapSimple (\t -> A.mul t =<< A.sub (A.fromInteger' 2) t)) $
   ramp dur

parabolaFadeOutMap dur =
   -- 1-t^2
   Causal.apply (Causal.mapSimple (\t -> A.sub (A.fromInteger' 1) =<< A.mul t t)) $
   ramp dur


{- |
@noise seed rate@

The @rate@ parameter is for adjusting the amplitude
such that it is uniform across different sample rates
and after frequency filters.
The @rate@ is the ratio of the current sample rate to the default sample rate,
where the variance of the samples would be one.
If you want that at sample rate 22050 the variance is 1,
then in order to get a consistent volume at sample rate 44100
you have to set @rate = 2@.

I use the variance as quantity and not the amplitude,
because the amplitude makes only sense for uniformly distributed samples.
However, frequency filters transform the probabilistic density of the samples
towards the normal distribution according to the central limit theorem.
-}
noise ::
   (Algebraic.C a, IsFloating a, IsConst a,
    NumberOfElements a ~ TypeNum.D1,
    Memory.C (Value a),
    IsSized a, MakeValueTuple a, ValueTuple a ~ (Value a), Storable a) =>
   Param.T p Word32 ->
   Param.T p a ->
   T p (Value a)
noise seed rate =
   let m2 = fromInteger $ div Rnd.modulus 2
   in  map (\r y ->
          A.mul r
           =<< flip A.sub (valueOf $ m2+1)
           =<< int31tofp y)
          (sqrt (3 * rate) / return m2) $
       noiseCore seed

{-
sitofp is a single instruction on x86
and thus we use it, since the arguments are below 2^31.
-}
int31tofp ::
   (IsFloating a, LLVM.NumberOfElements a ~ TypeNum.D1) =>
   Value Word32 -> CodeGenFunction r (Value a)
int31tofp =
   LLVM.inttofp <=<
   (LLVM.bitcast ::
       Value Word32 -> CodeGenFunction r (Value Int32))

noiseCore, noiseCoreAlt ::
   Param.T p Word32 ->
   T p (Value Word32)
noiseCore seed =
   iterate (const Rnd.nextCG)
      (return ()) ((+1) . flip mod (Rnd.modulus-1) ^<< seed)

noiseCoreAlt seed =
   iterate (const Rnd.nextCG32)
      (return ()) ((+1) . flip mod (Rnd.modulus-1) ^<< seed)


-- * conversion from and to storable vectors

fromStorableVector ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   Param.T p (SV.Vector a) ->
   T p value
fromStorableVector selectVec =
   Cons
      (\() (p0,l0) -> do
         cont <- Maybe.lift $ A.cmp CmpGT l0 (valueOf 0)
         Maybe.withBool cont $ do
            y1 <- Memory.load p0
            p1 <- advanceArrayElementPtr p0
            l1 <- A.dec l0
            return (y1,(p1,l1)))
      return
      (\p ->
         let (fp,s,l) = SVB.toForeignPtr $ Param.get selectVec p
         in  return (fp,
                ((),
                 (Memory.castStorablePtr $ Unsafe.foreignPtrToPtr fp `advancePtr` s,
                  fromIntegral l :: Word32))))
      -- keep the foreign ptr alive
      touchForeignPtr

{-
This function calls back into the Haskell function 'ChunkIt.next'
that returns a pointer to the data of the next chunk
and advances to the next chunk in the sequence.
-}
fromStorableVectorLazy ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   Param.T p (SVL.Vector a) ->
   T p value
fromStorableVectorLazy sig =
   Cons
      (\(stable, lenPtr) (buffer0,length0) -> do
         (buffer1,length1) <- Maybe.lift $ do
            nextChunkFn <- staticFunction ChunkIt.nextCallBack
            needNext <- A.cmp CmpEQ length0 (valueOf 0)
            ifThen needNext (buffer0,length0)
               (liftM2 (,)
                   (call nextChunkFn stable lenPtr)
                   (load lenPtr))
         valid <- Maybe.lift $ A.cmp CmpNE buffer1 (valueOf nullPtr)
         Maybe.withBool valid $ do
            x <- Memory.load buffer1
            buffer2 <- advanceArrayElementPtr buffer1
            length2 <- A.dec length1
            return (x, (buffer2,length2)))
      (\() -> return (valueOf nullPtr, valueOf 0))
      (\p -> do
          s <- liftM2 (,) (ChunkIt.new (Param.get sig p)) Alloc.malloc
          return (s, (s,())))
      (\(stable,lenPtr) -> do
          ChunkIt.dispose stable
          Alloc.free lenPtr)



piecewiseConstant ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   Param.T p (EventList.T NonNeg.Int a) ->
   T p value
piecewiseConstant =
   Const.flatten . Const.piecewiseConstant



{- |
Turns a lazy chunky size into a signal generator with unit element type.
The signal length is the only information that the generator provides.
Using 'zipWith' you can use this signal as a lazy 'take'.
-}
lazySize ::
   Param.T p SVP.LazySize ->
   T p ()
lazySize =
   Const.flatten . Const.lazySize


foreign import ccall safe "dynamic" derefFillPtr ::
   Exec.Importer (Ptr param -> Word32 -> Ptr a -> IO Word32)

run ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   T p value ->
   IO (Int -> p -> SV.Vector a)
run (Cons next start createIOContext deleteIOContext) =
   do -- this compiles once and is much faster than simpleFunction
      fill <-
         fmap derefFillPtr .
         Exec.compileModule .
         createNamedFunction ExternalLinkage "fillsignalblock" $
         \paramPtr size bPtr -> do
            (nextParam,startParam) <- Memory.load paramPtr
            s <- start startParam
            (pos,_) <- Maybe.arrayLoop size bPtr s $ \ ptri s0 -> do
               (y,s1) <- next nextParam s0
               Maybe.lift $ Memory.store y ptri
               return s1
            ret (pos :: Value Word32)

      return $ \len p ->
         Unsafe.performIO $
         bracket (createIOContext p) (deleteIOContext . fst) $
         \ (_,params) ->
            SVB.createAndTrim len $ \ ptr ->
            Alloc.with params $ \paramPtr ->
               (fmap fromIntegral $
                  fill (Memory.castStorablePtr paramPtr)
                     (fromIntegral len) (Memory.castStorablePtr ptr))

{- |
This is not really a function, see 'renderChunky'.
-}
render ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   T p value -> Int -> p -> SV.Vector a
render gen = Unsafe.performIO $ run gen


foreign import ccall safe "dynamic" derefChunkPtr ::
   Exec.Importer (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)


moduleChunky ::
   (Memory.C value, Memory.Struct value ~ struct,
    Memory.C state, Memory.Struct state ~ stateStruct,
    Memory.C startParamValue, Memory.Struct startParamValue ~ startParamStruct,
    Memory.C nextParamValue,  Memory.Struct nextParamValue ~ nextParamStruct) =>
   (forall r.
    nextParamValue ->
    state -> Maybe.T r (Value Bool, state) (value, state)) ->
   (forall r.
    startParamValue ->
    CodeGenFunction r state) ->
   CodeGenModule
      (Function (Ptr startParamStruct -> IO (Ptr stateStruct)),
       Function (Ptr stateStruct -> IO ()),
       Function (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32))
moduleChunky next start = liftM3 (,,)
   (createNamedFunction ExternalLinkage "startsignal" $
    \paramPtr -> do
       pptr <- LLVM.malloc
       flip Memory.store pptr =<< start =<< Memory.load paramPtr
       ret pptr)
   (createNamedFunction ExternalLinkage "stopsignal" $
    \ pptr -> LLVM.free pptr >> ret ())
   (createNamedFunction ExternalLinkage "fillsignal" $
    \ paramPtr sptr loopLen ptr -> do
       param <- Memory.load paramPtr
       sInit <- Memory.load sptr
       (pos,sExit) <- Maybe.arrayLoop loopLen ptr sInit $ \ ptri s0 -> do
          (y,s1) <- next param s0
          Maybe.lift $ Memory.store y ptri
          return s1
       Memory.store sExit sptr
       ret (pos :: Value Word32))

compileChunky ::
   (Memory.C value, Memory.Struct value ~ struct,
    Memory.C state, Memory.Struct state ~ stateStruct,
    Memory.C startParamValue, Memory.Struct startParamValue ~ startParamStruct,
    Memory.C nextParamValue,  Memory.Struct nextParamValue ~ nextParamStruct) =>
   (forall r.
    nextParamValue ->
    state -> Maybe.T r (Value Bool, state) (value, state)) ->
   (forall r.
    startParamValue ->
    CodeGenFunction r state) ->
   IO (FunPtr (Ptr startParamStruct -> IO (Ptr stateStruct)),
       FunPtr (Ptr stateStruct -> IO ()),
       FunPtr (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32))
compileChunky next start =
   Exec.compileModule $ moduleChunky next start

debugMain ::
   forall
      struct stateStruct
      startParamValue startParamStruct
      nextParamValue  nextParamStruct.
   (Storable startParamValue,
    Storable nextParamValue,
    LLVM.IsType struct,
    LLVM.IsType stateStruct,
    LLVM.IsType startParamStruct,
    LLVM.IsType nextParamStruct,
    IsSized    startParamStruct,
    IsSized    nextParamStruct) =>
   CodeGenModule
      (Function (Ptr startParamStruct -> IO (Ptr stateStruct)),
       Function (Ptr stateStruct -> IO ()),
       Function (Ptr nextParamStruct -> Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)) ->
   (nextParamValue, startParamValue) ->
   IO (Function (Word32 -> Ptr (Ptr Word8) -> IO Word32))
debugMain sigModule (nextParam, startParam) = do
{-
This does not work, since we cannot add (Mul n D32 s) constraint
to the function argument in reifyIntegral.
   nextArray <-
      DebugSt.withConstArray nextParam (\arr -> do
         ptr <- LLVM.alloca
         LLVM.store (value arr) ptr
         LLVM.bitcast ptr)
-}
   nextArray <-
      DebugSt.withConstArray nextParam (\arr -> do
         ptr <- LLVM.alloca
         LLVM.store (value arr) =<< LLVM.bitcast ptr
         return ptr)
   startArray <-
      DebugSt.withConstArray startParam (\arr -> do
         ptr <- LLVM.alloca
         LLVM.store (value arr) =<< LLVM.bitcast ptr
         return ptr)

   m <- LLVM.newModule

   mainFunc <- defineModule m (do
      mallocBytes <- LLVM.newNamedFunction ExternalLinkage "malloc" ::
         LLVM.TFunction (Ptr Word8 -> IO (Ptr struct))
      (start, stop, fill) <- sigModule
      createNamedFunction ExternalLinkage "main" $ \ _argc _argv -> do
         state <- LLVM.call start =<< startArray
         let chunkSize = LLVM.valueOf 100000
             basePtr = LLVM.valueOf nullPtr
         buffer <-
            LLVM.call mallocBytes =<<
            LLVM.bitcast =<<
            LLVM.getElementPtr basePtr (chunkSize, ())
         nextPtr <- nextArray
         _done <-
            LLVM.call fill nextPtr state chunkSize (asTypeOf buffer basePtr)
         _ <- LLVM.call stop state
         ret (LLVM.value LLVM.zero :: LLVM.Value Word32))

   Counter.with Exec.counter $ R.ReaderT $ \cnt -> do
      writeBitcodeToFile ("main" ++ Counter.format 3 cnt ++ ".bc") m

   return mainFunc



{- |
Renders a signal generator to a chunky storable vector with given pattern.
If the pattern is shorter than the generated signal
this means that the signal is shortened.
-}
runChunkyPattern ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   T p value ->
   IO (SVP.LazySize -> p -> SVL.Vector a)
runChunkyPattern (Cons next start createIOContext deleteIOContext) = do
   (startFunc, stopFunc, fill) <- compileChunky next start
   return $
      \ lazysize p -> SVL.fromChunks $ Unsafe.performIO $ do
         (ioContext, (nextParam, startParam)) <- createIOContext p

{-
         putStr "nextParam: "
         DebugSt.format nextParam >>= putStrLn
-}
         when False $ Counter.with DebugSt.dumpCounter $ do
            DebugSt.dump "next-param" nextParam
            DebugSt.dump "start-param" startParam

         when False $ void $
            debugMain (moduleChunky next start) (nextParam, startParam)

         statePtr <- ForeignPtr.newParam stopFunc startFunc startParam
         nextParamPtr <- ForeignPtr.new (deleteIOContext ioContext) nextParam

         let go cs =
                Unsafe.interleaveIO $
                case cs of
                   [] -> return []
                   SVL.ChunkSize size : rest -> do
                      v <-
                         withForeignPtr statePtr $ \sptr ->
                         ForeignPtr.with nextParamPtr $ \nptr ->
                         SVB.createAndTrim size $
                         fmap fromIntegral .
                         derefChunkPtr fill nptr sptr (fromIntegral size) .
                         Memory.castStorablePtr
                      (if SV.length v > 0
                         then fmap (v:)
                         else id) $
                         (if SV.length v < size
                            then return []
                            else go rest)
         go (Chunky.toChunks lazysize)

runChunky ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   T p value ->
   IO (SVL.ChunkSize -> p -> SVL.Vector a)
runChunky sig =
   flip fmap (runChunkyPattern sig) $ \f size p ->
      f (Chunky.fromChunks (repeat size)) p

{- |
This looks like a function,
but it is not a function since it depends on LLVM being initialized
with LLVM.initializeNativeTarget before.
It is also problematic since you cannot control when and how often
the underlying LLVM code is compiled.
The compilation cannot be observed, thus it is referential transparent.
But this influences performance considerably
and I assume that you use this package exclusively for performance reasons.
-}
renderChunky ::
   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>
   SVL.ChunkSize -> T p value ->
   p -> SVL.Vector a
renderChunky size gen =
   Unsafe.performIO (runChunky gen) size