packages feed

synthesizer-llvm 0.8 → 0.8.1

raw patch · 24 files changed

+543/−350 lines, 24 files

Files

example/Synthesizer/LLVM/Test.hs view
@@ -427,15 +427,19 @@        Sig.osci Wave.sine 0 (0.1/44100)) $    chord 0.005 +lfoSineCausal ::+   CausalP.T p (Value Float) a -> Param.T p Float -> SigP.T p a+lfoSineCausal f reduct =+   CausalP.apply f $+   Sig.map (\x -> 0.01 * exp (2 * return x)) $+   SigP.osciSimple Wave.sine 0 (reduct * 0.1/44100)+ lfoSine ::    (Memory.C a) =>    (forall r. Value Float -> LLVM.CodeGenFunction r a) ->    Param.T p Float ->    SigP.T p a-lfoSine f reduct =-   Sig.map f $-   Sig.map (\x -> 0.01 * exp (2 * return x)) $-   SigP.osciSimple Wave.sine 0 (reduct * 0.1/44100)+lfoSine f = lfoSineCausal (Causal.map f)  filterSweep :: IO () filterSweep =@@ -493,7 +497,10 @@    flip (SigP.renderChunky (SVL.chunkSize 10000)) () $    (CausalPS.amplify 0.2 .     CtrlPS.processCtrlRate 128-       (lfoSine (Butterworth.parameter TypeNum.d3 FiltR.Lowpass (valueOf 0.5)))+      (lfoSineCausal+         (CausalClass.applyConstFst+            (Butterworth.parameterCausal TypeNum.d3 FiltR.Lowpass)+            (valueOf 0.5)))       $* SigPS.noise 0 0.3)  chebyshevNoisePacked :: IO ()@@ -504,7 +511,10 @@    flip (SigP.renderChunky (SVL.chunkSize 10000)) () $    (CausalPS.amplify 0.2 .     CtrlPS.processCtrlRate 128-       (lfoSine (Chebyshev.parameterA TypeNum.d5 FiltR.Lowpass (valueOf 0.5)))+      (lfoSineCausal+         (CausalClass.applyConstFst+            (Chebyshev.parameterCausalA TypeNum.d5 FiltR.Lowpass)+            (valueOf 0.5)))       $* SigPS.noise 0 0.3)  {-
src/Synthesizer/LLVM/Causal/Process.hs view
@@ -613,20 +613,22 @@     Memory.C bValue, Memory.Struct bValue ~ bStruct,     Memory.C param, Memory.Struct param ~ paramStruct,     Phi state, Undefined state) =>-   (forall r z.-    (Phi z) => param -> aValue -> state -> MaybeCont.T r z (bValue, state)) ->+   (forall r z. (Phi z) =>+    param -> local -> aValue -> state -> MaybeCont.T r z (bValue, state)) ->+   (forall r. CodeGenFunction r local) ->    (forall r. param -> CodeGenFunction r state) ->    IO (Ptr paramStruct -> Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32)-compile next start =+compile next alloca start =    Exec.compileModule $       Exec.createFunction derefFillPtr "fillprocessblock" $          \ paramPtr size alPtr blPtr -> do             param <- Memory.load paramPtr             s <- start param+            local <- alloca             (pos,_) <- MaybeCont.arrayLoop2 size alPtr blPtr s $                   \ aPtri bPtri s0 -> do                a <- MaybeCont.lift $ Memory.load aPtri-               (b,s1) <- next param a s0+               (b,s1) <- next param local a s0                MaybeCont.lift $ Memory.store b bPtri                return s1             ret pos@@ -648,8 +650,8 @@    (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA,     Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) =>    T valueA valueB -> IO (SV.Vector a -> IO (SV.Vector b))-runStorableIO (Cons next start createIOContext deleteIOContext) = do-   fill <- compile next start+runStorableIO (Cons next alloca start createIOContext deleteIOContext) = do+   fill <- compile next alloca start    return $ \as ->       bracket createIOContext (deleteIOContext . fst) $ \ (_ioContext, params) ->          SVB.withStartPtr as $ \ aPtr len ->@@ -680,16 +682,16 @@     Memory.C bValue, Memory.Struct bValue ~ bStruct,     Memory.C param, Memory.Struct param ~ paramStruct,     Memory.C state, Memory.Struct state ~ stateStruct) =>-   (forall r z.-    (Phi z) =>-    param -> aValue -> state -> MaybeCont.T r z (bValue, state)) ->+   (forall r z. (Phi z) =>+    param -> local -> aValue -> state -> MaybeCont.T r z (bValue, state)) ->+   (forall r. CodeGenFunction r local) ->    (forall r.     param -> CodeGenFunction r state) ->    IO (Ptr paramStruct -> IO (Ptr stateStruct),        Exec.Finalizer stateStruct,        Ptr paramStruct -> Ptr stateStruct ->        Word32 -> Ptr aStruct -> Ptr bStruct -> IO Word32)-compileChunky next start =+compileChunky next alloca start =    Exec.compileModule $       liftA3 (,,)          (Exec.createFunction derefStartPtr "startprocess" $@@ -704,10 +706,11 @@           \paramPtr sptr loopLen aPtr bPtr -> do              sInit <- Memory.load sptr              param <- Memory.load paramPtr+             local <- alloca              (pos,sExit) <- MaybeCont.arrayLoop2 loopLen aPtr bPtr sInit $                    \ aPtri bPtri s0 -> do                 a <- MaybeCont.lift $ Memory.load aPtri-                (b,s1) <- next param a s0+                (b,s1) <- next param local a s0                 MaybeCont.lift $ Memory.store b bPtri                 return s1              Memory.store (Maybe.fromJust sExit) sptr@@ -754,8 +757,8 @@    (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA,     Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) =>    T valueA valueB -> IO (SVL.Vector a -> SVL.Vector b)-runStorableChunky (Cons next start createIOContext deleteIOContext) = do-   (startFunc, stopFunc, fill) <- compileChunky next start+runStorableChunky (Cons next alloca start createIOContext deleteIOContext) = do+   (startFunc, stopFunc, fill) <- compileChunky next alloca start    return $ \sig -> SVL.fromChunks $ Unsafe.performIO $ do       (ioContext, params) <- createIOContext       paramPtr <- ForeignPtr.new (deleteIOContext ioContext) params
src/Synthesizer/LLVM/Causal/ProcessPrivate.hs view
@@ -54,7 +54,9 @@                -- extract final state for cleanup  -class CausalClass.C process => C process where+class+   (CausalClass.C process, Sig.C (CausalClass.SignalOf process)) =>+      C process where    simple ::       (Memory.C state) =>       (forall r c.@@ -64,9 +66,9 @@       process a b     alter ::-      (forall context initState exitState.-          Core context initState exitState a0 b0 ->-          Core context initState exitState a1 b1) ->+      (forall contextLocal initState exitState.+          Core contextLocal initState exitState a0 b0 ->+          Core contextLocal initState exitState a1 b1) ->       process a0 b0 -> process a1 b1     replicateControlled ::@@ -76,9 +78,9 @@  alterSignal ::    (C process, CausalClass.SignalOf process ~ signal) =>-   (forall context initState exitState.-       Sig.Core context initState exitState a0 ->-       Core context initState exitState a1 b1) ->+   (forall contextLocal initState exitState.+       Sig.Core contextLocal initState exitState a0 ->+       Core contextLocal initState exitState a1 b1) ->    signal a0 -> process a1 b1 alterSignal f =    alter (\(Core next start stop) -> f (Sig.Core (\c -> next c ()) start stop))@@ -88,17 +90,20 @@   data T a b =-   forall state ioContext parameters.+   forall state local ioContext parameters.       (Storable parameters,        MakeValueTuple parameters,        Memory.C (ValueTuple parameters),        Memory.C state) =>       Cons (forall r c.             (Phi c) =>-            ValueTuple parameters ->+            ValueTuple parameters -> local ->             a -> state -> MaybeCont.T r c (b, state))                -- compute next value            (forall r.+            CodeGenFunction r local)+               -- allocate temporary variables before a loop+           (forall r.             ValueTuple parameters ->             CodeGenFunction r state)                -- initial state@@ -118,15 +123,16 @@ instance C T where    simple next start =       Cons-         (const next)+         (const $ \ () -> next)+         (return ())          (const start)          (return ((),()))          (const $ return ()) -   alter f (Cons next0 start0 create delete) =-      case f (Core next0 start0 id) of+   alter f (Cons next0 alloca start0 create delete) =+      case f (Core (uncurry next0) start0 id) of          Core next1 start1 _ ->-            Cons next1 start1 create delete+            Cons (curry next1) alloca start1 create delete     {-    Could be implemented with a machine code loop like in CausalParameterized.@@ -136,14 +142,16 @@   toSignal :: T () a -> Sig.T a-toSignal (Cons next start createIOContext deleteIOContext) = Sig.Cons-   (\ioContext -> next ioContext ())+toSignal (Cons next alloca start createIOContext deleteIOContext) = Sig.Cons+   (\ioContext local -> next ioContext local ())+   alloca    start    createIOContext deleteIOContext  fromSignal :: Sig.T b -> T a b-fromSignal (Sig.Cons next start createIOContext deleteIOContext) = Cons-   (\ioContext _ -> next ioContext)+fromSignal (Sig.Cons next alloca start createIOContext deleteIOContext) = Cons+   (\ioContext local _ -> next ioContext local)+   alloca    start    createIOContext deleteIOContext @@ -189,12 +197,13 @@  compose :: T a b -> T b c -> T a c compose-      (Cons nextA startA createIOContextA deleteIOContextA)-      (Cons nextB startB createIOContextB deleteIOContextB) = Cons-   (\(paramA, paramB) a (sa0,sb0) -> do-      (b,sa1) <- nextA paramA a sa0-      (c,sb1) <- nextB paramB b sb0+      (Cons nextA allocaA startA createIOContextA deleteIOContextA)+      (Cons nextB allocaB startB createIOContextB deleteIOContextB) = Cons+   (\(paramA, paramB) (localA, localB) a (sa0,sb0) -> do+      (b,sa1) <- nextA paramA localA a sa0+      (c,sb1) <- nextB paramB localB b sb0       return (c, (sa1,sb1)))+   (liftM2 (,) allocaA allocaB)    (Sig.combineStart startA startB)    (Sig.combineCreate createIOContextA createIOContextB)    (Sig.combineDelete deleteIOContextA deleteIOContextB)
src/Synthesizer/LLVM/CausalParameterized/Functional.hs view
@@ -50,7 +50,7 @@ import qualified Control.Category as Cat import Control.Arrow (Arrow, (>>^), (&&&), arr, first, ) import Control.Category (Category, (.), )-import Control.Applicative (Applicative, (<*>), pure, )+import Control.Applicative (Applicative, (<*>), pure, liftA2, )  import Foreign.Storable (Storable, ) @@ -66,7 +66,7 @@  -- | similar to @CausalP.T p a b@ data Code p a b =-   forall context state ioContext parameters.+   forall context local state ioContext parameters.       (Storable parameters,        MakeValueTuple parameters,        Memory.C (ValueTuple parameters),@@ -75,10 +75,13 @@    Code       (forall r c.        (Phi c) =>-       context -> a -> state ->+       context -> local -> a -> state ->        StateT Vault (Maybe.T r c) (b, state))           -- compute next value       (forall r.+       CodeGenFunction r local)+          -- allocate temporary variables before a loop+      (forall r.        ValueTuple parameters ->        CodeGenFunction r (context, state))           -- initial state@@ -98,11 +101,12 @@  instance Category (Code p) where    id = arr id-   Code nextB startB stopB createIOContextB deleteIOContextB .-      Code nextA startA stopA createIOContextA deleteIOContextA = Code+   Code nextB allocaB startB stopB createIOContextB deleteIOContextB .+      Code nextA allocaA startA stopA createIOContextA deleteIOContextA = Code          (CausalP.composeNext              (State.mapStateT . Maybe.onFail)              stopA stopB nextA nextB)+         (liftA2 (,) allocaA allocaB)          (CausalP.composeStart startA startB)          (CausalP.composeStop stopA stopB)          (CausalP.composeCreate createIOContextA createIOContextB)@@ -111,13 +115,14 @@  instance Arrow (Code p) where    arr f = Code-      (\ _p a () -> return (f a, ()))+      (\ _p () a () -> return (f a, ()))+      (return ())       (\() -> return ((),()))       (\() () -> return ())       (const $ return ((),()))       (const $ return ())-   first (Code next start stop create delete) = Code-      (Causal.firstNext next) start stop+   first (Code next alloca start stop create delete) = Code+      (curry $ Causal.firstNext $ uncurry next) alloca start stop       create delete  @@ -215,10 +220,10 @@   liftCode :: CausalP.T p inp out -> Code p inp out-liftCode (CausalP.Cons next start stop create delete) =+liftCode (CausalP.Cons next alloca start stop create delete) =    Code-      (\p a state -> Trans.lift (next p a state))-      start stop create delete+      (\p l a state -> Trans.lift (next p l a state))+      alloca start stop create delete  lift :: CausalP.T p inp out -> T p inp out lift = tagUnique . liftCode@@ -227,18 +232,18 @@ fromSignal = lift . CausalP.fromSignal  tag :: Vault.Key out -> Code p inp out -> T p inp out-tag key (Code next start stop create delete) =+tag key (Code next alloca start stop create delete) =    Cons $    Code-      (\p a s0 -> do+      (\p l a s0 -> do          mb <- State.gets (Vault.lookup key)          case mb of             Just b -> return (b,s0)             Nothing -> do-               bs@(b,_) <- next p a s0+               bs@(b,_) <- next p l a s0                State.modify (Vault.insert key b)                return bs)-      start stop create delete+      alloca start stop create delete  -- dummy for debugging _tag :: Vault.Key out -> Code p inp out -> T p inp out@@ -250,10 +255,10 @@    fmap (flip tag code) Vault.newKey  initialize :: Code p inp out -> CausalP.T p inp out-initialize (Code next start stop create delete) =+initialize (Code next alloca start stop create delete) =    CausalP.Cons-      (\p a state -> State.evalStateT (next p a state) Vault.empty)-      start stop create delete+      (\p l a state -> State.evalStateT (next p l a state) Vault.empty)+      alloca start stop create delete  compile :: T p inp out -> CausalP.T p inp out compile (Cons code) = initialize code
src/Synthesizer/LLVM/CausalParameterized/Helix.hs view
@@ -325,12 +325,13 @@ peekCell margin period32 vec =    Param.with (Param.word32 $ fmap Ip.marginOffset margin) $ \getOffset valueOffset ->    Param.with period32 $ \getPeriod valuePeriod -> CausalPrivP.Cons-      (\(p,off,per) n () -> MaybeCont.lift $ do+      (\(p,off,per) () n () -> MaybeCont.lift $ do          offset <- A.sub n (valueOffset off)          nodes <-             Ip.loadNodes (Ip.loadNodes Memory.load A.one) (valuePeriod per)                =<< LLVM.getElementPtr p (offset, ())          return (nodes, ()))+      (return ())       (return . flip (,) ())       (const $ const $ return ())       (\p ->@@ -463,7 +464,8 @@    SigP.T p (Value t, Value t) limitShapeSignal margin periodInt len =    SigP.Cons-      (\minMax () -> return (minMax, ()))+      (\minMax () () -> return (minMax, ()))+      (return ())       (\(minShapeInt, maxShapeInt) -> do          minShape <- LLVM.inttofp minShapeInt          maxShape <- LLVM.inttofp maxShapeInt@@ -487,9 +489,10 @@    CausalP.T p t t _limitShape margin periodInt len =    CausalPrivP.Cons-      (\(minShape,maxShape) shape () -> MaybeCont.lift $ do+      (\(minShape,maxShape) () shape () -> MaybeCont.lift $ do          limited <- A.min maxShape =<< A.max minShape shape          return (limited, ()))+      (return ())       (\minmax -> return (minmax, ()))       (const $ const $ return ())       (\p ->
src/Synthesizer/LLVM/CausalParameterized/Process.hs view
@@ -175,8 +175,8 @@   reparameterize :: Param.T q p -> T p a b -> T q a b-reparameterize p (Cons start stop next create delete) =-   Cons start stop next (create . Param.get p) delete+reparameterize p (Cons start alloca stop next create delete) =+   Cons start alloca stop next (create . Param.get p) delete   mapAccumSimple ::@@ -209,9 +209,10 @@    Param.T p [a] -> T p (c,x) x replicateControlledParam f ps =    case f (arr fst) (arr snd) of-      Cons next start stop createIOContext deleteIOContext -> Cons+      Cons next alloca start stop createIOContext deleteIOContext -> Cons          (replicateControlledNext next stop) --         (_replicateControlledNext next)+         alloca          (replicateControlledStart start)          (replicateControlledStop stop)          (\p ->@@ -237,8 +238,10 @@ stereoFromMono ::    (Phi a, Phi b, Undefined b) =>    T p a b -> T p (Stereo.T a) (Stereo.T b)-stereoFromMono (Cons next start stop createIOContext deleteIOContext) = Cons+stereoFromMono+      (Cons next alloca start stop createIOContext deleteIOContext) = Cons    (stereoNext stop next)+   alloca    (stereoStart start)    (stereoStop stop)    (stereoCreate createIOContext createIOContext)@@ -256,8 +259,9 @@    Param.T p (Stereo.T x) -> T p (Stereo.T a) (Stereo.T b) stereoFromMonoParameterized f ps =    case f (arr fst) (arr snd) of-      Cons next start stop createIOContext deleteIOContext -> Cons+      Cons next alloca start stop createIOContext deleteIOContext -> Cons          (stereoNext stop next)+         alloca          (stereoStart start)          (stereoStop stop)          (stereoCreate@@ -278,15 +282,16 @@    (Phi a, Phi b, Phi c, Phi s, Phi context,     Undefined b, Undefined s) =>    (context -> s -> CodeGenFunction r ()) ->-   (forall z. (Phi z) => context -> a -> s -> MaybeCont.T r z (b, s)) ->+   (forall z. (Phi z) => context -> local -> a -> s -> MaybeCont.T r z (b, s)) ->    Stereo.T context ->+   local ->    Stereo.T a ->    Stereo.T s ->    MaybeCont.T r c (Stereo.T b, Stereo.T s)-stereoNext stop next context a s0 = MaybeCont.fromMaybe $ do+stereoNext stop next context local a s0 = MaybeCont.fromMaybe $ do    mbs1 <-       twiceStereo-         (MaybeCont.toMaybe . uncurry3 next)+         (MaybeCont.toMaybe . uncurry3 (flip next local))          (liftA3 (,,) context a s0)     mbs2 <-@@ -673,8 +678,8 @@    SigP.T (p,a) b ->    T p (Maybe.T al) (Maybe.T b) triggerAux-      (SigPPriv.Cons next start stop createIOContext deleteIOContext) = Cons-   (\(creator, eraser) mx mcsio0 -> MaybeCont.lift $ do+   (SigPPriv.Cons next alloca start stop createIOContext deleteIOContext) = Cons+   (\(creator, eraser) (local, (param, xPtr)) mx mcsio0 -> MaybeCont.lift $ do       mcsio1 <-          Maybe.run mx             (return mcsio0)@@ -682,16 +687,15 @@                stopAndDelete eraser stop mcsio0                >>                do-                  param <- LLVM.alloca-                  xPtr <- LLVM.alloca                   Memory.store x xPtr                   io <- LLVM.call creator param xPtr                   cs <- start =<< Memory.load param                   return $ Maybe.just (cs, io))       mcasio2 <-          Maybe.run mcsio1 (return Maybe.nothing) $ \((c1,s1), io1) ->-            MaybeCont.toMaybe $ fmap (flip (,) io1 . (,) c1) $ next c1 s1+            MaybeCont.toMaybe $ fmap (flip (,) io1 . (,) c1) $ next c1 local s1       return (fmap (fst.snd.fst) mcasio2, fmap (mapFst (mapSnd snd)) mcasio2))+   (liftA2 (,) alloca $ liftA2 (,) LLVM.alloca LLVM.alloca)    (\ce -> return (ce, Maybe.nothing))    (\(_creator, eraser) mcsio ->       stopAndDelete eraser stop mcsio)@@ -733,17 +737,18 @@     Storable b, MakeValueTuple b, ValueTuple b ~ valueB, Memory.C valueB) =>    T p valueA valueB ->    IO (p -> SV.Vector a -> SV.Vector b)-runStorable (Cons next start stop createIOContext deleteIOContext) = do+runStorable (Cons next alloca start stop createIOContext deleteIOContext) = do    fill <-       Exec.compileModule $       Exec.createFunction derefFillPtr "fillprocessblock" $       \paramPtr size alPtr blPtr -> do          param <- Memory.load paramPtr          (c,s) <- start param+         local <- alloca          (pos,msExit) <- MaybeCont.arrayLoop2 size alPtr blPtr s $                \ aPtri bPtri s0 -> do             a <- MaybeCont.lift $ Memory.load aPtri-            (b,s1) <- next c a s0+            (b,s1) <- next c local a s0             MaybeCont.lift $ Memory.store b bPtri             return s1          Maybe.for msExit $ stop c@@ -785,9 +790,10 @@     Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>    (forall r z.     (Phi z) =>-    context ->+    context -> local ->     valueA -> state ->     MaybeCont.T r z (valueB, state)) ->+   (forall r. CodeGenFunction r local) ->    (forall r.     parameters ->     CodeGenFunction r (context, state)) ->@@ -798,7 +804,7 @@        Exec.Finalizer contextStateStruct,        Ptr contextStateStruct -> Word32 ->          Ptr structA -> Ptr structB -> IO Word32)-compileChunky next start stop =+compileChunky next alloca start stop =    Exec.compileModule $       liftA3 (,,)          (Exec.createFunction derefStartPtr "startprocess" $@@ -815,12 +821,13 @@          (Exec.createFunction derefChunkPtr "fillprocess" $           \ contextStatePtr loopLen aPtr bPtr -> do              (param, msInit) <- Memory.load contextStatePtr+             local <- alloca              (pos,msExit) <-                 Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->                    MaybeCont.arrayLoop2 loopLen aPtr bPtr sInit $                       \ aPtri bPtri s0 -> do                 a <- MaybeCont.lift $ Memory.load aPtri-                (b,s1) <- next param a s0+                (b,s1) <- next param local a s0                 MaybeCont.lift $ Memory.store b bPtri                 return s1              sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())@@ -850,9 +857,10 @@     LLVM.CodeGenFunction r stateIn) ->    (forall r z.     (Phi z) =>-    context ->+    context -> local ->     valueA -> state ->     MaybeCont.T r z (valueB, state)) ->+   (forall r. CodeGenFunction r local) ->    (forall r.     parameters ->     CodeGenFunction r (context, state)) ->@@ -869,7 +877,7 @@        Ptr contextStateStruct -> IO (),        Ptr contextStateStruct -> Word32 ->          Ptr paramStructIn -> Ptr paramStructOut -> IO Word32)-compilePlugged nextIn startIn next start stop nextOut startOut =+compilePlugged nextIn startIn next alloca start stop nextOut startOut =    Exec.compileModule $       liftA3 (,,)          (Exec.createFunction derefStartPtr "startprocess" $@@ -890,12 +898,13 @@              outParam <- Memory.load outPtr              inInit  <- startIn  inParam              outInit <- startOut outParam+             local <- alloca              (pos,msExit) <-                 Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->                    MaybeCont.fixedLengthLoop loopLen (inInit, sInit, outInit) $                       \ (in0,s0,out0) -> do                 (a,in1) <- MaybeCont.lift $ nextIn inParam in0-                (b,s1) <- next param a s0+                (b,s1) <- next param local a s0                 out1 <- MaybeCont.lift $ nextOut outParam b out0                 return (in1, s1, out1)              sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())@@ -924,8 +933,9 @@    IO ((SVL.Vector a -> SVL.Vector b) ->        p ->        SVL.Vector a -> SVL.Vector b)-runStorableChunkyCont (Cons next start stop createIOContext deleteIOContext) = do-   (startFunc, stopFunc, fill) <- compileChunky next start stop+runStorableChunkyCont+      (Cons next alloca start stop createIOContext deleteIOContext) = do+   (startFunc, stopFunc, fill) <- compileChunky next alloca start stop    return $       \ procRest p sig ->       SVL.fromChunks $ Unsafe.performIO $ do@@ -1003,10 +1013,10 @@    IO (p -> PIO.T a d) processIOCore       (PIn.Cons nextIn startIn createIn deleteIn)-      (Cons next start stop createIOContext deleteIOContext)+      (Cons next alloca start stop createIOContext deleteIOContext)       (POut.Cons nextOut startOut createOut deleteOut) = do    (startFunc, stopFunc, fill) <--      compilePlugged nextIn startIn next start stop nextOut startOut+      compilePlugged nextIn startIn next alloca start stop nextOut startOut    return $ \p -> PIO.Cons       (\a s@(_, paramPtr) -> do          let maximumSize = Cut.length a
src/Synthesizer/LLVM/CausalParameterized/ProcessPrivate.hs view
@@ -55,7 +55,7 @@   data T p a b =-   forall context state ioContext parameters.+   forall context state local ioContext parameters.       (Storable parameters,        MakeValueTuple parameters,        Memory.C (ValueTuple parameters),@@ -64,10 +64,13 @@    Cons       (forall r c.        (Phi c) =>-       context ->+       context -> local ->        a -> state -> MaybeCont.T r c (b, state))           -- compute next value       (forall r.+       CodeGenFunction r local)+          -- allocate temporary variables before a loop+      (forall r.        ValueTuple parameters ->        CodeGenFunction r (context, state))           -- initial state@@ -95,11 +98,11 @@    simple next start =       simple (\() -> next) (\() -> fmap ((,) ()) start) (pure ()) -   alter f (Cons next0 start0 stop0 create delete) =-      case f (CausalPriv.Core next0 return id) of+   alter f (Cons next0 alloca start0 stop0 create delete) =+      case f (CausalPriv.Core (uncurry next0) return id) of          CausalPriv.Core next1 start1 stop1 ->             Cons-               next1+               (curry next1) alloca                (Sig.withStart start0 start1)                (\c -> stop0 c . stop1)                create delete@@ -121,7 +124,10 @@     CodeGenFunction r (context, state)) ->    Param.T p parameters -> T p a b simple f start param =-   Param.with param $ \get value -> Cons f+   Param.with param $ \get value ->+   Cons+      (\context () -> f context)+      (return ())       (start . value)       (const $ const $ return ())       (return . (,) () . get)@@ -129,14 +135,18 @@   toSignal :: T p () a -> Sig.T p a-toSignal (Cons next start stop createIOContext deleteIOContext) = Sig.Cons-   (\p -> next p ())+toSignal+      (Cons next alloca start stop createIOContext deleteIOContext) = Sig.Cons+   (\p l -> next p l ())+   alloca    start stop    createIOContext deleteIOContext  fromSignal :: Sig.T p b -> T p a b-fromSignal (Sig.Cons next start stop createIOContext deleteIOContext) = Cons-   (\p _ -> next p)+fromSignal+      (Sig.Cons next alloca start stop createIOContext deleteIOContext) = Cons+   (\p l _ -> next p l)+   alloca    start stop    createIOContext deleteIOContext @@ -207,10 +217,11 @@ -} compose :: T p a b -> T p b c -> T p a c compose-      (Cons nextA startA stopA createIOContextA deleteIOContextA)-      (Cons nextB startB stopB createIOContextB deleteIOContextB) =+      (Cons nextA allocaA startA stopA createIOContextA deleteIOContextA)+      (Cons nextB allocaB startB stopB createIOContextB deleteIOContextB) =    Cons       (composeNext MaybeCont.onFail stopA stopB nextA nextB)+      (M.lift2 (,) allocaA allocaB)       (composeStart startA startB)       (composeStop stopA stopB)       (composeCreate createIOContextA createIOContextB)@@ -221,19 +232,21 @@    (forall x. code () -> maybe x -> maybe x) ->    (contextA -> stateA -> code ()) ->    (contextB -> stateB -> code ()) ->-   (contextA -> a -> stateA -> maybe (b, stateA)) ->-   (contextB -> b -> stateB -> maybe (c, stateB)) ->+   (contextA -> localA -> a -> stateA -> maybe (b, stateA)) ->+   (contextB -> localB -> b -> stateB -> maybe (c, stateB)) ->    (contextA, contextB) ->+   (localA, localB) ->    a ->    (stateA, stateB) ->    maybe (c, (stateA, stateB))-composeNext onFail stopA stopB nextA nextB (paramA, paramB) a (sa0,sb0) = do+composeNext onFail stopA stopB nextA nextB+      (paramA, paramB) (localA, localB) a (sa0,sb0) = do    (b,sa1) <-       onFail (stopB paramB sb0) $-      nextA paramA a sa0+      nextA paramA localA a sa0    (c,sb1) <-       onFail (stopA paramA sa1) $-      nextB paramB b sb0+      nextB paramB localB b sb0    return (c, (sa1,sb1))  composeStart ::@@ -271,11 +284,14 @@ replicateControlled ::    (Undefined x, Phi x) =>    Param.T p Int -> T p (c,x) x -> T p (c,x) x-replicateControlled n (Cons next start stop createIOContext deleteIOContext) =+replicateControlled+      n (Cons next alloca start stop createIOContext deleteIOContext) =    case Param.word32 n of       n32 -> Cons          (\(len, cs) ->             replicateControlledNext next stop (Param.value n32 len, cs))+         (-- we re-use the temporary variable for all stages)+          alloca)          (\(len, param) ->             replicateControlledStart start (Param.value n32 len, param))          (\(len, cs) ->@@ -291,14 +307,15 @@        LLVM.Struct (Memory.Struct context, (Memory.Struct state, ())),     Phi z, Phi a, Undefined a) =>    (forall z0. (Phi z0) =>-    context -> (ctrl, a) -> state ->+    context -> local -> (ctrl, a) -> state ->     MaybeCont.T r z0 (a, state)) ->    (context -> state -> CodeGenFunction r ()) ->    (Value Word32, Value (Ptr contextState)) ->+   local ->    (ctrl, a) ->    () ->    MaybeCont.T r z (a, ())-replicateControlledNext next stop (len, contextStates) (c,a) () =+replicateControlledNext next stop (len, contextStates) local (c,a) () =    MaybeCont.fromMaybe $ fmap (\(_,ms) -> flip (,) () <$> ms) $       MaybeCont.arrayLoop len contextStates a $             \contextStatePtr a0 -> do@@ -307,7 +324,7 @@             MaybeCont.onFail                (replicateControlledStopExcept                   stop len contextStates contextStatePtr) $-            next context (c,a0) s0+            next context local (c,a0) s0          MaybeCont.lift $             Memory.store s1 =<< LLVM.getElementPtr0 contextStatePtr (d1, ())          return a1@@ -450,9 +467,10 @@ loop ::    (Storable c, MakeValueTuple c, ValueTuple c ~ cl, Memory.C cl) =>    Param.T p c -> T p (a,cl) (b,cl) -> T p a b-loop initial (Cons next start stop createIOContext deleteIOContext) =+loop initial (Cons next alloca start stop createIOContext deleteIOContext) =    Param.with initial $ \getInitial valueInitial -> Cons-      (loopNext next)+      (curry $ loopNext $ uncurry next)+      alloca       (\(i,p) -> fmap (mapSnd ((,) (valueInitial i))) $ start p)       (loopStop stop)       (\p -> do
src/Synthesizer/LLVM/CausalParameterized/RingBuffer.hs view
@@ -37,6 +37,7 @@    Param.with (Param.word32 time) $ \getTime valueTime ->       CausalP.Cons          (trackNext valueTime)+         (return ())          (\(x, size) -> trackStart valueTime (valueInitial x, size))          trackStop          (trackCreate getInitial getTime)@@ -54,6 +55,7 @@    Param.with (Param.word32 time) $ \getTime valueTime ->       CausalP.Cons          (trackNext valueTime)+         (return ())          (\size -> trackStart valueTime (initial, size))          trackStop          (trackConstCreate getTime)
src/Synthesizer/LLVM/CausalParameterized/RingBufferForward.hs view
@@ -109,10 +109,11 @@ trackSkip ::    (Memory.C a) =>    Param.T p Int -> SigP.T p a -> CausalP.T p (Value Word32) (T a)-trackSkip time (SigP.Cons next start stop create delete) =+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)@@ -156,10 +157,11 @@    <<<    trackSkipHold_ time xs -trackSkipHold_ time (SigP.Cons next start stop create delete) =+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)@@ -169,18 +171,19 @@ trackNext ::    (Memory.C al, Memory.Struct al ~ am, Phi z,     Phi state, Class.Undefined state) =>-   (forall z0. (Phi z0) => context -> state -> MaybeCont.T r z0 (al, state)) ->+   (forall z0. (Phi z0) =>+    context -> local -> state -> MaybeCont.T r z0 (al, state)) ->    (tl -> Value Word32) ->-   (context, (tl, Value (Ptr am))) ->+   (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)) n1 (n0, statePos) = do+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 state0+         (a, state1) <- next context local state0          MaybeCont.lift $             fmap ((,) state1) $ storeNext (size0,ptr) a pos0    return (Cons ptr size0 pos3, (n1, (state3, pos3)))@@ -214,15 +217,17 @@ trackNextHold ::    (Memory.C al, Memory.Struct al ~ am, Phi z,     Phi state, Class.Undefined state) =>-   (forall z0. (Phi z0) => context -> state -> MaybeCont.T r z0 (al, state)) ->+   (forall z0. (Phi z0) =>+    context -> local -> state -> MaybeCont.T r z0 (al, state)) ->    (tl -> Value Word32) ->-   (context, (tl, Value (Ptr am))) ->+   (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)) nNext (n0, (mstate0, pos0)) =+trackNextHold+   next valueTime (context, (size,ptr)) local nNext (n0, (mstate0, pos0)) =       MaybeCont.lift $ do    let size0 = valueTime size    (n3, (pos3, state3)) <-@@ -235,7 +240,8 @@                   fmap (mapSnd ((,) n1 . (,) pos1)) $                      C.ifThen cont                         (Maybe.nothing, Maybe.just state1)-                        (do aState <- MaybeCont.toMaybe $ next context 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
src/Synthesizer/LLVM/Complex.hs view
@@ -2,6 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Synthesizer.LLVM.Complex (    Complex.T(Complex.real, Complex.imag),+   Struct,    (Complex.+:),    Complex.cis,    Complex.scale,
src/Synthesizer/LLVM/ConstantPiece.hs view
@@ -102,8 +102,7 @@    Param.T p (EventList.T NonNeg.Int a) ->    SigP.T p (T value) piecewiseConstant evs = SigP.Cons-   (\stable () -> do-      yPtr <- Maybe.lift $ LLVM.alloca+   (\stable yPtr () -> do       len <- Maybe.lift $ do          nextFn <-             LLVM.staticNamedFunction@@ -114,6 +113,7 @@          Maybe.lift (A.cmp LLVM.CmpNE len A.zero)       y <- Maybe.lift $ Memory.load yPtr       return (Cons len y, ()))+   LLVM.alloca    return    (const $ const $ return ())    (\p -> do@@ -126,7 +126,7 @@    Param.T p SVP.LazySize ->    SigP.T p (T ()) lazySize size = SigP.Cons-   (\stable () -> do+   (\stable () () -> do       len <- Maybe.lift $ do          nextFn <-             LLVM.staticNamedFunction@@ -136,6 +136,7 @@       Maybe.guard =<<          Maybe.lift (A.cmp LLVM.CmpNE len A.zero)       return (Cons len (), ()))+   (return ())    return    (const $ const $ return ())    (\p -> do
src/Synthesizer/LLVM/Filter/Allpass.hs view
@@ -54,15 +54,13 @@  import qualified Control.Category as Cat import qualified Control.Applicative as App-import qualified Data.Foldable as Fold-import qualified Data.Traversable as Trav import Control.Arrow ((<<<), (^<<), (<<^), (&&&), arr, first, second, )++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold import Data.Tuple.HT (mapPair, )  import qualified Algebra.Transcendental as Trans--- import qualified Algebra.Field as Field--- import qualified Algebra.Module as Module--- import qualified Algebra.Ring as Ring  import NumericPrelude.Numeric import NumericPrelude.Base
src/Synthesizer/LLVM/Filter/Butterworth.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} module Synthesizer.LLVM.Filter.Butterworth (-   parameter, Cascade.ParameterValue,+   parameter, parameterCausal, Cascade.ParameterValue,    Cascade.causal,  Cascade.causalPacked,    Cascade.causalP, Cascade.causalPackedP,    Cascade.fixSize,@@ -11,11 +11,13 @@  import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2+import qualified Synthesizer.LLVM.Causal.ProcessPrivate as Causal+import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig+import qualified Synthesizer.LLVM.Simple.Value as Value  import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butterworth import Synthesizer.Plain.Filter.Recursive (Passband, )--import qualified Synthesizer.LLVM.Simple.Value as Value+import Synthesizer.Causal.Class (($<), )  import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Control as U@@ -26,63 +28,70 @@    (Value, valueOf, constOf,     IsFloating, IsSized, SizeOf,     CodeGenFunction, )+ import Data.Word (Word32, ) +import Foreign.Ptr (Ptr, )+ import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal.Number ((:*:), ) import Type.Base.Proxy (Proxy, )  import qualified Algebra.Transcendental as Trans--- import qualified Algebra.Field as Field--- import qualified Algebra.Module as Module--- import qualified Algebra.Ring as Ring  import NumericPrelude.Numeric import NumericPrelude.Base  -parameter, parameterMalloc, _parameterAlloca ::++parameterCausal ::+   (Causal.C process,+    Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,+    TypeNum.Natural n,+    TypeNum.Positive (n :*: SizeOf a),+    IsSized (Cascade.ParameterStruct n a)) =>+   Proxy n -> Passband ->+   process (Value a, Value a) (Cascade.ParameterValue n a)+parameterCausal n kind =+   Causal.map+      (\((psine, ps), (ratio, freq)) ->+         parameterCore n kind psine ps ratio freq)+   $<+   Sig.zipWith (curry return) Sig.alloca Sig.alloca++parameter ::    (Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,     TypeNum.Natural n,     TypeNum.Positive (n :*: SizeOf a),     IsSized (Cascade.ParameterStruct n a)) =>    Proxy n -> Passband -> Value a -> Value a ->    CodeGenFunction r (Cascade.ParameterValue n a)-parameter = parameterMalloc--parameterMalloc n kind ratio freq = do-   let order = 2 * TypeNum.integralFromProxy n-   partialRatio <- Value.unlift1 (Butterworth.partialRatio order) ratio-   let sines =-          Cascade.constArray n $-          map constOf $ Butterworth.makeSines order+parameter n kind ratio freq = do    psine <- LLVM.malloc-   LLVM.store sines psine-   s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ())    ps <- LLVM.malloc-   p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ())-   let len = valueOf $ (TypeNum.integralFromProxy n :: Word32)-   _ <- U.arrayLoop len p s $ \ptri si -> do-      sinw <- LLVM.load si-      flip LLVM.store ptri =<<-         Filt2.composeParameter =<<-         Value.unlift3 (Butterworth.partialParameter kind) partialRatio sinw freq-      A.advanceArrayElementPtr si-   pv <- LLVM.load ps-   LLVM.free psine+   pv <- parameterCore n kind psine ps ratio freq    LLVM.free ps-   return (Cascade.ParameterValue pv)+   LLVM.free psine+   return pv -_parameterAlloca n kind ratio freq = do+parameterCore ::+   (Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,+    TypeNum.Natural n,+    TypeNum.Positive (n :*: SizeOf a),+    IsSized (Cascade.ParameterStruct n a)) =>+   Proxy n -> Passband ->+   Value (Ptr (LLVM.Array n a)) ->+   Value (Ptr (Cascade.ParameterStruct n a)) ->+   Value a -> Value a ->+   CodeGenFunction r (Cascade.ParameterValue n a)+parameterCore n kind psine ps ratio freq = do    let order = 2 * TypeNum.integralFromProxy n    partialRatio <- Value.unlift1 (Butterworth.partialRatio order) ratio    let sines =           Cascade.constArray n $           map constOf $ Butterworth.makeSines order-   psine <- LLVM.alloca    LLVM.store sines psine    s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ())-   ps <- LLVM.alloca    p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ())    let len = valueOf $ (TypeNum.integralFromProxy n :: Word32)    _ <- U.arrayLoop len p s $ \ptri si -> do
src/Synthesizer/LLVM/Filter/Chebyshev.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} module Synthesizer.LLVM.Filter.Chebyshev (+   parameterCausalA, parameterCausalB,    parameterA, parameterB, Cascade.ParameterValue,    Cascade.causal,  Cascade.causalPacked,    Cascade.causalP, Cascade.causalPackedP,@@ -11,12 +12,14 @@  import qualified Synthesizer.LLVM.Filter.SecondOrderCascade as Cascade import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2+import qualified Synthesizer.LLVM.Causal.ProcessPrivate as Causal+import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig+import qualified Synthesizer.LLVM.Simple.Value as Value  import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Chebyshev import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core import Synthesizer.Plain.Filter.Recursive (Passband, )--import qualified Synthesizer.LLVM.Simple.Value as Value+import Synthesizer.Causal.Class (($<), )  import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Control as U@@ -27,6 +30,8 @@    (Value, valueOf, IsSized, SizeOf, IsFloating, CodeGenFunction, ) import Data.Word (Word32, ) +import Foreign.Ptr (Ptr, )+ import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal.Number ((:*:), ) import Type.Base.Proxy (Proxy, )@@ -42,9 +47,42 @@   {- |-'n' must be at least one in order to allow amplification+@n@ must be at least one in order to allow amplification by the first partial filter.+The causal processes should be more efficient+than 'parameterA' and 'parameterB'+because they use stack-based @alloca@ instead of @malloc@. -}+parameterCausalA, parameterCausalB ::+   (Causal.C process,+    Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,+    TypeNum.Positive n, TypeNum.Natural n,+    TypeNum.Positive (n :*: SizeOf a),+    IsSized (Cascade.ParameterStruct n a), SizeOf (Cascade.ParameterStruct n a) ~ paramSize,+    (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.Positive paramSize) =>+   Proxy n -> Passband ->+   process (Value a, Value a) (Cascade.ParameterValue n a)+parameterCausalA n kind =+   Causal.map+      (\((psine, ps), (ratio, freq)) ->+         fmap Cascade.ParameterValue $+         adjustAmplitude ratio =<<+         parameter Chebyshev.partialParameterA n kind psine ps ratio freq)+   $<+   allocaArrays++parameterCausalB n kind =+   Causal.map+      (\((psine, ps), (ratio, freq)) ->+         fmap Cascade.ParameterValue $+         parameter Chebyshev.partialParameterB n kind psine ps ratio freq)+   $<+   allocaArrays++allocaArrays ::+   (Sig.C signal, IsSized a, IsSized b) => signal (Value (Ptr a), Value (Ptr b))+allocaArrays = Sig.zipWith (curry return) Sig.alloca Sig.alloca+ parameterA, parameterB ::    (Trans.C a, SoV.TranscendentalConstant a, IsFloating a, IsSized a,     TypeNum.Positive n, TypeNum.Natural n,@@ -53,22 +91,44 @@     (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.Positive paramSize) =>    Proxy n -> Passband -> Value a -> Value a ->    CodeGenFunction r (Cascade.ParameterValue n a)-parameterA n kind ratio freq = do-   pv <- parameter Chebyshev.partialParameterA n kind ratio freq+parameterA n kind ratio freq =+   withArrays $ \psine ps ->+      fmap Cascade.ParameterValue $+      adjustAmplitude ratio =<<+      parameter Chebyshev.partialParameterA n kind psine ps ratio freq -   -- adjust amplification of the first filter+parameterB n kind ratio freq =+   withArrays $ \psine ps ->+      fmap Cascade.ParameterValue $+      parameter Chebyshev.partialParameterB n kind psine ps ratio freq++withArrays ::+   (LLVM.IsSized a, LLVM.IsSized b) =>+   (Value (Ptr a) -> Value (Ptr b) -> CodeGenFunction r c) ->+   CodeGenFunction r c+withArrays act = do+   psine <- LLVM.malloc+   ps <- LLVM.malloc+   x <- act psine ps+   LLVM.free psine+   LLVM.free ps+   return x+++-- | adjust amplification of the first filter+adjustAmplitude ::+   (LLVM.IsArithmetic a, IsSized a, SoV.IntegerConstant a,+    Filt2.ParameterStruct a ~ filt2, TypeNum.Natural n) =>+   Value a -> Value (LLVM.Array n filt2) ->+   CodeGenFunction r (Value (LLVM.Array n filt2))+adjustAmplitude ratio pv = do    filt0 <-       Filt2.decomposeParameter =<<       LLVM.extractvalue pv (0::Word32)-   fmap Cascade.ParameterValue $-      flip (LLVM.insertvalue pv) (0::Word32) =<<-         Filt2.composeParameter =<<-         Value.flatten-            (Filt2Core.amplify (Value.constantValue ratio) (Value.unfold filt0))--parameterB n kind ratio freq =-   fmap Cascade.ParameterValue $-   parameter Chebyshev.partialParameterB n kind ratio freq+   flip (LLVM.insertvalue pv) (0::Word32) =<<+      Filt2.composeParameter =<<+      Value.flatten+         (Filt2Core.amplify (Value.constantValue ratio) (Value.unfold filt0))   parameter ::@@ -79,18 +139,19 @@     IsSized (Cascade.ParameterStruct n a), SizeOf (Cascade.ParameterStruct n a) ~ paramSize,     (n :*: LLVM.UnknownSize) ~ paramSize, TypeNum.Positive paramSize) =>    (Passband -> Int -> av -> Complex.T av -> av -> Filt2Core.Parameter av) ->-   Proxy n -> Passband -> Value a -> Value a ->+   Proxy n -> Passband ->+   Value (Ptr (LLVM.Array n (ComplexL.Struct a))) ->+   Value (Ptr (Cascade.ParameterStruct n a)) ->+   Value a -> Value a ->    CodeGenFunction r (Value (Cascade.ParameterStruct n a))-parameter partialParameter n kind ratio freq = do+parameter partialParameter n kind psine ps ratio freq = do    let order = TypeNum.integralFromProxy n    let sines =           Cascade.constArray n $           map ComplexL.constOf $           Chebyshev.makeCirclePoints order-   psine <- LLVM.malloc    LLVM.store sines psine    s <- LLVM.getElementPtr0 psine (valueOf (0::Word32), ())-   ps <- LLVM.malloc    p <- LLVM.getElementPtr0 ps (valueOf (0::Word32), ())    let len = valueOf $ (TypeNum.integralFromProxy n :: Word32)    _ <- U.arrayLoop len p s $ \ptri si -> do@@ -104,7 +165,4 @@                (Value.constantValue freq))       A.advanceArrayElementPtr si -   pv <- LLVM.load ps-   LLVM.free psine-   LLVM.free ps-   return pv+   LLVM.load ps
src/Synthesizer/LLVM/Filter/ComplexFirstOrder.hs view
@@ -24,9 +24,10 @@ import Type.Data.Num.Decimal (d0, d1, d2, )  import qualified Control.Applicative as App-import qualified Data.Foldable as Fold-import qualified Data.Traversable as Trav import Control.Applicative (liftA2, liftA3, (<*>), )++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold  import NumericPrelude.Numeric import NumericPrelude.Base
src/Synthesizer/LLVM/Filter/NonRecursive.hs view
@@ -8,9 +8,8 @@    ) where  import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP-import qualified Synthesizer.LLVM.Parameter as Param- import qualified Synthesizer.LLVM.CausalParameterized.RingBuffer as RingBuffer+import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Frame.SerialVector as Serial  import qualified Synthesizer.LLVM.Storable.Vector as SVU@@ -85,7 +84,8 @@    Param.T p (SV.Vector a) -> CausalP.T p x (Value (Ptr am)) provideMask mask =    CausalP.Cons-      (\p _x () -> return (p,()))+      (\p () _x () -> return (p,()))+      (return ())       return       (const $ const $ return ())       (\p ->
src/Synthesizer/LLVM/Filter/SecondOrderCascade.hs view
@@ -17,9 +17,11 @@ import qualified Synthesizer.LLVM.CausalParameterized.Functional as Func import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Causal.Process as Causal+import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )  import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import Synthesizer.Causal.Class (($<), )  import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Class as Class@@ -38,13 +40,10 @@ import Data.Word (Word32, )  import qualified Control.Arrow as Arrow-import Control.Arrow ((>>>), (<<<), (^<<), (<<^), (&&&), arr, )+import Control.Arrow ((>>>), (<<<), (^<<), (&&&), arr, ) import Control.Applicative (liftA2, ) --- import qualified Algebra.Transcendental as Trans--- import qualified Algebra.Field as Field--- import qualified Algebra.Module as Module--- import qualified Algebra.Ring as Ring+import Foreign.Ptr (Ptr, )  import NumericPrelude.Numeric import NumericPrelude.Base@@ -173,14 +172,20 @@       Causal.replicateControlled          (TypeNum.integralFromSingleton n)          (paramStage stage)-      <<^-      (\(p,v) -> (p, (A.zero, v)))+      <<<+      Causal.map+         (\(ptr, (p,v)) -> do+            LLVM.store (parameterValue p) ptr+            return (ptr, (A.zero, v)))+      $<+      Sig.alloca  paramStage ::    (Causal.C process, IsSized a,     TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>    process (Filt2Core.Parameter (Value a), v) v ->-   process (ParameterValue n a, (Value Word32, v)) (Value Word32, v)+   process+      (Value (Ptr (ParameterStruct n a)), (Value Word32, v)) (Value Word32, v) paramStage stage =    let p = arr fst        i = arr (fst.snd)@@ -188,7 +193,7 @@    in  (Causal.map A.inc <<< i)        &&&        (stage <<<-           (Causal.zipWith getStageParameterMalloc <<< p &&& i)+           (Causal.zipWith getStageParameterGEP <<< p &&& i)            &&&            v) @@ -196,12 +201,13 @@    (IsSized a,     TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>    CausalP.T p (Filt2Core.Parameter (Value a), v) v ->-   CausalP.T p (ParameterValue n a, (Value Word32, v)) (Value Word32, v)+   CausalP.T p+      (Value (Ptr (ParameterStruct n a)), (Value Word32, v)) (Value Word32, v) _paramStage stage =    Func.withGuidedArgs (Func.atom, (Func.atom, Func.atom)) $ \(p,(i,v)) ->       liftA2 (,) (i+1)          (stage $&-             (Causal.zipWith getStageParameterMalloc $& p &|& i)+             (Causal.zipWith getStageParameterGEP $& p &|& i)              &|&              v) @@ -234,39 +240,16 @@    Memory.compose ps -} -getStageParameterMalloc, _getStageParameterAlloca ::+getStageParameterGEP ::    (IsSized a,     TypeNum.Natural n, TypeNum.Positive (n :*: LLVM.UnknownSize)) =>-   ParameterValue n a ->-   Value Word32 ->-   CodeGenFunction r (Filt2Core.Parameter (Value a))-{--Expensive because we need a heap allocation for every sample.-However, we could allocate the memory once in the Causal initialization routine.--}-getStageParameterMalloc ps k = do-   ptr <- LLVM.malloc-   LLVM.store (parameterValue ps) ptr-   p <--      Filt2.decomposeParameter-       =<< LLVM.load-       =<< LLVM.getElementPtr0 ptr (k, ())-   LLVM.free ptr-   return p--{--With this implementation, LLVM-2.6 generates a stack variable layout-that requires non-aligned access to vector values.-The result is a crash at runtime.-Even if the layout is right,-alloca will run in a loop and will finally run out of stack space.--}-_getStageParameterAlloca ps k = do-   ptr <- LLVM.alloca-   LLVM.store (parameterValue ps) ptr+   Value (Ptr (ParameterStruct n a)) ->+   Value Word32 -> CodeGenFunction r (Filt2Core.Parameter (Value a))+getStageParameterGEP ptr k =    Filt2.decomposeParameter     =<< LLVM.load     =<< LLVM.getElementPtr0 ptr (k, ())+  {-# DEPRECATED causalP          "use 'causal' instead" #-} {-# DEPRECATED causalPackedP    "use 'causalPacked' instead" #-}
src/Synthesizer/LLVM/Filter/SecondOrderPacked.hs view
@@ -32,9 +32,6 @@ import Control.Applicative (liftA2, )  import qualified Algebra.Transcendental as Trans--- import qualified Algebra.Field as Field--- import qualified Algebra.Module as Module--- import qualified Algebra.Ring as Ring  import NumericPrelude.Numeric import NumericPrelude.Base
src/Synthesizer/LLVM/Parameterized/Signal.hs view
@@ -66,6 +66,7 @@    ) where  import Synthesizer.LLVM.Parameterized.SignalPrivate+import qualified Synthesizer.LLVM.Simple.SignalPrivate as SigPriv import qualified Synthesizer.LLVM.Simple.Signal as Sig import qualified Synthesizer.LLVM.CausalParameterized.ProcessPrivate as CausalP import qualified Synthesizer.LLVM.Causal.Process as Causal@@ -101,7 +102,7 @@ import qualified LLVM.Extra.Memory as Memory import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, ) import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )-import LLVM.Extra.Control (whileLoop, ifThen, )+import LLVM.Extra.Control (whileLoop, )  import qualified LLVM.ExecutionEngine as EE import qualified LLVM.Util.Loop as Loop@@ -147,8 +148,8 @@   reparameterize :: Param.T q p -> T p a -> T q a-reparameterize p (Cons start stop next create delete) =-   Cons start stop next (create . Param.get p) delete+reparameterize p (Cons start alloca stop next create delete) =+   Cons start alloca stop next (create . Param.get p) delete   -- * timeline edit@@ -158,11 +159,13 @@ -} tail ::    T p a -> T p a-tail (Cons next start stop createIOContext deleteIOContext) = Cons+tail (Cons next alloca start stop createIOContext deleteIOContext) = Cons    next+   alloca    (\parameter -> do+      local <- alloca       (c,s0) <- start parameter-      MaybeCont.resolve (next c s0)+      MaybeCont.resolve (next c local s0)          (return (c,s0))          (\(_a,s1) -> return (c,s1)))    stop@@ -172,10 +175,12 @@ drop ::    Param.T p Int ->    T p a -> T p a-drop n (Cons next start stop createIOContext deleteIOContext) =+drop n (Cons next alloca start stop createIOContext deleteIOContext) =    Param.with (Param.word32 n) $ \getN valueN -> Cons    next+   alloca    (\(parameter, i0) -> do+      local <- alloca       (c,s0) <- start parameter       (_, _, s3) <-          whileLoop (valueOf True, valueN i0, s0)@@ -184,7 +189,7 @@                   A.cmp LLVM.CmpGT i1 A.zero)             (\(_cont,i1,s1) -> do                (cont, s2) <--                  MaybeCont.resolve (next c s1)+                  MaybeCont.resolve (next c local s1)                      (return (valueOf False, s1))                      (\(_a,s) -> return (valueOf True, s))                i2 <- A.dec i1@@ -218,15 +223,15 @@    (Loop.Phi a, Undefined a) =>    T p a -> T p a -> T p a append-      (Cons nextA startA stopA createIOContextA deleteIOContextA)-      (Cons nextB startB stopB createIOContextB deleteIOContextB) =+      (Cons nextA allocaA startA stopA createIOContextA deleteIOContextA)+      (Cons nextB allocaB startB stopB createIOContextB deleteIOContextB) =    Cons-      (\parameterB ecs0 -> MaybeCont.fromMaybe $ do+      (\parameterB (localA, localB) ecs0 -> MaybeCont.fromMaybe $ do          ecs1 <-             Either.run ecs0                (\(ca, sa0) ->                   MaybeCont.resolve-                     (nextA ca sa0)+                     (nextA ca localA sa0)                      (fmap Either.right $ startB parameterB)                      (\(a1,sa1) -> return (Either.left (a1, (ca, sa1)))))                (return . Either.right)@@ -237,7 +242,8 @@             (\(cb,sb0) ->                MaybeCont.toMaybe $                fmap (\(b,sb1) -> (b, Either.right (cb,sb1))) $-               nextB cb sb0))+               nextB cb localB sb0))+      (liftM2 (,) allocaA allocaB)       (\(parameterA, parameterB) -> do          cs <- startA parameterA          return (parameterB, Either.left cs))@@ -248,14 +254,15 @@ cycle ::    (Loop.Phi a, Undefined a) =>    T p a -> T p a-cycle (Cons next start stop createIOContext deleteIOContext) =+cycle (Cons next alloca start stop createIOContext deleteIOContext) =    Cons-      (\parameter (c0,s0) ->+      (\parameter local (c0,s0) ->           MaybeCont.alternative-             (fmap (mapSnd ((,) c0)) $ next c0 s0)+             (fmap (mapSnd ((,) c0)) $ next c0 local s0)              (do (c1,s1) <- MaybeCont.lift $ start parameter-                 (b0,s2) <- next c1 s1+                 (b0,s2) <- next c1 local s1                  return (b0,(c1,s2))))+      alloca       (\parameter -> do          contextState <- start parameter          return (parameter, contextState))@@ -564,13 +571,14 @@    T p value fromStorableVector selectVec =    Cons-      (\() (p0,l0) -> do+      (\() () (p0,l0) -> do          cont <- MaybeCont.lift $ A.cmp LLVM.CmpGT l0 A.zero          MaybeCont.withBool cont $ do             y1 <- Memory.load p0             p1 <- advanceArrayElementPtr p0             l1 <- A.dec l0             return (y1,(p1,l1)))+      (return ())       (return . (,) ())       (\() _ -> return ())       (\p ->@@ -588,27 +596,19 @@    (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>    Param.T p (SVL.Vector a) ->    T p value-fromStorableVectorLazy sig =+fromStorableVectorLazy = SigPriv.flattenChunks . storableVectorChunks++storableVectorChunks ::+   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value,+    Memory.Struct value ~ struct) =>+   Param.T p (SVL.Vector a) ->+   T p (Value (Ptr struct), Value Word32)+storableVectorChunks sig =    Cons-      (\stable (buffer0,length0) -> do-         (buffer1,length1) <- MaybeCont.lift $ do-            nextChunkFn <--               LLVM.staticNamedFunction-                  "Parameterized.Signal.fromStorableVectorLazy.nextChunk"-                  ChunkIt.nextCallBack-            needNext <- A.cmp LLVM.CmpEQ length0 A.zero-            ifThen needNext (buffer0,length0)-               (do lenPtr <- LLVM.alloca-                   liftM2 (,)-                      (LLVM.call nextChunkFn stable lenPtr)-                      (LLVM.load lenPtr))-         valid <- MaybeCont.lift $ A.cmp LLVM.CmpNE buffer1 (valueOf nullPtr)-         MaybeCont.withBool valid $ do-            x <- Memory.load buffer1-            buffer2 <- advanceArrayElementPtr buffer1-            length2 <- A.dec length1-            return (x, (buffer2,length2)))-      (\s -> return (s, (valueOf nullPtr, A.zero)))+      (SigPriv.storableVectorNextChunk+         "Parameterized.Signal.fromStorableVectorLazy.nextChunk")+      LLVM.alloca+      (\s -> return (s, ()))       (\ _s _ -> return ())       (\p -> do           s <- ChunkIt.new (Param.get sig p)@@ -648,20 +648,22 @@     Loop.Phi state, Undefined state) =>    (forall r z.     (Loop.Phi z) =>-    context -> state -> MaybeCont.T r z (value, state)) ->+    context -> local -> state -> MaybeCont.T r z (value, state)) ->+   (forall r. CodeGenFunction r local) ->    (forall r.     parameters -> CodeGenFunction r (context, state)) ->    (forall r.     context -> state -> CodeGenFunction r ()) ->    CodeGenModule       (Function (Ptr paramStruct -> Word32 -> Ptr struct -> IO Word32))-moduleFill next start stop =+moduleFill next alloca start stop =    Exec.createLLVMFunction "fillsignalblock" $    \paramPtr size bPtr -> do       param <- Memory.load paramPtr       (c,s) <- start param+      local <- alloca       (pos,se) <- MaybeCont.arrayLoop size bPtr s $ \ ptri s0 -> do-         (y,s1) <- next c s0+         (y,s1) <- next c local s0          MaybeCont.lift $ Memory.store y ptri          return s1       Maybe.for se $ stop c@@ -713,20 +715,20 @@    (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>    T p value ->    IO (Int -> p -> SV.Vector a)-run (Cons next start stop createIOContext deleteIOContext) =+run (Cons next alloca start stop createIOContext deleteIOContext) =    do -- this compiles once and is much faster than simpleFunction       fill <-          Exec.compileModule $          Compose $             (EE.getExecutionFunction derefFillPtr-               <$> moduleFill next start stop)+               <$> moduleFill next alloca start stop)        return $ \len p ->          Unsafe.performIO $          bracket (createIOContext p) (deleteIOContext . fst) $          \ (_,params) -> do             when False $ void $-               debugMain (moduleFill next start stop) params+               debugMain (moduleFill next alloca start stop) params              SVB.createAndTrim len $ \ ptr ->                Alloc.with params $ \paramPtr ->@@ -760,7 +762,8 @@     Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>    (forall r z.     (Loop.Phi z) =>-    context -> state -> MaybeCont.T r z (value, state)) ->+    context -> local -> state -> MaybeCont.T r z (value, state)) ->+   (forall r. CodeGenFunction r local) ->    (forall r.     parameters -> CodeGenFunction r (context, state)) ->    (forall r.@@ -770,7 +773,7 @@        Function (Ptr contextStateStruct -> IO ()),        Function (Ptr contextStateStruct ->                  Word32 -> Ptr struct -> IO Word32))-moduleChunky next start stop = liftA3 (,,)+moduleChunky next alloca start stop = liftA3 (,,)    (Exec.createLLVMFunction "startsignal" $     \paramPtr -> do        pptr <- LLVM.malloc@@ -785,10 +788,11 @@    (Exec.createLLVMFunction "fillsignal" $     \ contextStatePtr loopLen ptr -> do        (context, msInit) <- Memory.load contextStatePtr+       local <- alloca        (pos,msExit) <-           Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->              MaybeCont.arrayLoop loopLen ptr sInit $ \ ptri s0 -> do-          (y,s1) <- next context s0+          (y,s1) <- next context local s0           MaybeCont.lift $ Memory.store y ptri           return s1        sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())@@ -802,7 +806,8 @@     Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>    (forall r z.     (Loop.Phi z) =>-    context -> state -> MaybeCont.T r z (value, state)) ->+    context -> local -> state -> MaybeCont.T r z (value, state)) ->+   (forall r. CodeGenFunction r local) ->    (forall r.     parameters -> CodeGenFunction r (context, state)) ->    (forall r.@@ -810,7 +815,7 @@    IO (Ptr paramStruct -> IO (Ptr contextStateStruct),        Exec.Finalizer contextStateStruct,        Ptr contextStateStruct -> Word32 -> Ptr struct -> IO Word32)-compileChunky next start stop =+compileChunky next alloca start stop =    Exec.compileModule $    Compose       ((\(startF, stopF, nextF) ->@@ -819,7 +824,7 @@             (liftA2 (,) EE.getEngine $              EE.getExecutionFunction derefStopPtr stopF)             (EE.getExecutionFunction derefChunkPtr nextF))-         <$> moduleChunky next start stop)+         <$> moduleChunky next alloca start stop)  debugChunkyMain ::    forall parameters struct paramStruct contextStateStruct.@@ -887,8 +892,9 @@    (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>    T p value ->    IO (SVP.LazySize -> p -> SVL.Vector a)-runChunkyPattern (Cons next start stop createIOContext deleteIOContext) = do-   (startFunc, stopFunc, fill) <- compileChunky next start stop+runChunkyPattern+      (Cons next alloca start stop createIOContext deleteIOContext) = do+   (startFunc, stopFunc, fill) <- compileChunky next alloca start stop    return $       \ lazysize p -> SVL.fromChunks $ Unsafe.performIO $ do          (ioContext, param) <- createIOContext p@@ -901,7 +907,7 @@             DebugSt.dump "param" param           when False $ void $-            debugChunkyMain (moduleChunky next start stop) param+            debugChunkyMain (moduleChunky next alloca start stop) param           statePtr <- ForeignPtr.newParam stopFunc startFunc param          ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext)
src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs view
@@ -62,7 +62,7 @@ Consider a signal algorithm, where the LFO frequency is a parameter. -} data T p a =-   forall context state ioContext parameters.+   forall context state local ioContext parameters.       (Storable parameters,        MakeValueTuple parameters,        Memory.C (ValueTuple parameters),@@ -71,9 +71,12 @@    Cons       (forall r c.        (Phi c) =>-       context -> state -> Maybe.T r c (a, state))+       context -> local -> state -> Maybe.T r c (a, state))           -- compute next value       (forall r.+       CodeGenFunction r local)+          -- allocate temporary variables before a loop+      (forall r.        ValueTuple parameters ->        CodeGenFunction r (context, state))           -- allocate initial state@@ -95,19 +98,21 @@   instance Sig.C (T p) where-   simple next start =+   simpleAlloca next alloca0 start =       Cons-         (\() -> next)+         (\() local -> next local)+         alloca0          (const $ fmap ((,) ()) start)          (const $ const $ return ())          (const $ return ((), ()))          (const $ return ()) -   alter f (Cons next0 start0 stop0 create delete) =-      case f (Sig.Core next0 return id) of+   alter f (Cons next0 alloca0 start0 stop0 create delete) =+      case f (Sig.Core (uncurry next0) return id) of          Sig.Core next1 start1 stop1 ->             Cons-               next1+               (curry next1)+               alloca0                (withStart start0 start1)                (\c -> stop0 c . stop1)                create delete@@ -174,7 +179,10 @@     CodeGenFunction r (context, state)) ->    Param.T p parameters -> T p al simple f start param =-   Param.with param $ \getParam valueParam -> Cons f+   Param.with param $ \getParam valueParam ->+   Cons+      (\context () state -> f context state)+      (return ())       (start . valueParam)       (const $ const $ return ())       (return . (,) () . getParam)@@ -215,17 +223,18 @@    map (uncurry . f) param $ zip as bs  zip :: T p a -> T p b -> T p (a,b)-zip (Cons nextA startA stopA createIOContextA deleteIOContextA)-    (Cons nextB startB stopB createIOContextB deleteIOContextB) =+zip (Cons nextA allocaA startA stopA createIOContextA deleteIOContextA)+    (Cons nextB allocaB startB stopB createIOContextB deleteIOContextB) =    Cons-      (\(parameterA, parameterB) (sa0,sb0) -> do+      (\(parameterA, parameterB) (localA, localB) (sa0,sb0) -> do          (a,sa1) <-             Maybe.onFail (stopB parameterB sb0) $-            nextA parameterA sa0+            nextA parameterA localA sa0          (b,sb1) <-             Maybe.onFail (stopA parameterA sa1) $-            nextB parameterB sb0+            nextB parameterB localB sb0          return ((a,b), (sa1,sb1)))+      (liftM2 (,) allocaA allocaB)       (combineStart startA startB)       (combineStop stopA stopB)       (combineCreate createIOContextA createIOContextB)@@ -305,7 +314,8 @@ malloc :: (LLVM.IsSized a) => T p (LLVM.Value (Ptr a)) malloc =    Cons-      (\ptr () -> return (ptr, ()))+      (\ptr () () -> return (ptr, ()))+      (return ())       (const $ fmap (flip (,) ()) $ LLVM.malloc)       (\ptr () -> LLVM.free ptr)       (const $ return ((), ()))
src/Synthesizer/LLVM/RingBuffer.hs view
@@ -69,10 +69,10 @@ trackNext ::    (Memory.C al, Memory.Struct al ~ am) =>    (tl -> Value Word32) ->-   (tl, Value (Ptr am)) ->+   (tl, Value (Ptr am)) -> () ->    al -> Value Word32 ->    Maybe.T r z (T al, Value Word32)-trackNext valueTime (size,ptr) a remain0 = Maybe.lift $ do+trackNext valueTime (size,ptr) () a remain0 = Maybe.lift $ do    Memory.store a =<< LLVM.getElementPtr ptr (remain0, ())    cont <- A.cmp LLVM.CmpGT remain0 A.zero    let size0 = valueTime size
src/Synthesizer/LLVM/Simple/Signal.hs view
@@ -31,7 +31,7 @@    runChunky,    ) where -import Synthesizer.LLVM.Simple.SignalPrivate+import Synthesizer.LLVM.Simple.SignalPrivate hiding (alloca)  import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame@@ -51,7 +51,6 @@ import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )-import LLVM.Extra.Control (ifThen, ) import LLVM.Extra.Class (MakeValueTuple, ValueTuple, valueTupleOf, )  import qualified LLVM.Core as LLVM@@ -69,7 +68,7 @@ import Foreign.Storable.Tuple () import Foreign.Storable (Storable, ) import Foreign.ForeignPtr (touchForeignPtr, withForeignPtr, )-import Foreign.Ptr (Ptr, nullPtr, )+import Foreign.Ptr (Ptr, ) import Data.Word (Word32, ) import Control.Exception (bracket, ) @@ -181,13 +180,14 @@ fromStorableVector xs =    let (fp,ptr,l) = SVU.unsafeToPointers xs    in  Cons-          (\_ (p0,l0) -> do+          (\_ () (p0,l0) -> do              cont <- MaybeCont.lift $ A.cmp LLVM.CmpGT l0 A.zero              MaybeCont.withBool cont $ do                 y1 <- Memory.load p0                 p1 <- advanceArrayElementPtr p0                 l1 <- A.dec l0                 return (y1,(p1,l1)))+          (return ())           (const $ return              (valueOf ptr,               valueOf (fromIntegral l :: Word32)))@@ -204,27 +204,18 @@    (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>    SVL.Vector a ->    T value-fromStorableVectorLazy sig =+fromStorableVectorLazy = flattenChunks . storableVectorChunks++storableVectorChunks ::+   (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value,+    Memory.Struct value ~ struct) =>+   SVL.Vector a ->+   T (Value (Ptr struct), Value Word32)+storableVectorChunks sig =    Cons-      (\stable (buffer0,length0) -> do-         (buffer1,length1) <- MaybeCont.lift $ do-            nextChunkFn <--               LLVM.staticNamedFunction-                  "Simple.Signal.fromStorableVectorLazy.nextChunk"-                  ChunkIt.nextCallBack-            needNext <- A.cmp LLVM.CmpEQ length0 A.zero-            ifThen needNext (buffer0,length0)-               (do lenPtr <- LLVM.alloca-                   liftM2 (,)-                      (LLVM.call nextChunkFn stable lenPtr)-                      (LLVM.load lenPtr))-         valid <- MaybeCont.lift $ A.cmp LLVM.CmpNE buffer1 (valueOf nullPtr)-         MaybeCont.withBool valid $ do-            x <- Memory.load buffer1-            buffer2 <- advanceArrayElementPtr buffer1-            length2 <- A.dec length1-            return (x, (buffer2,length2)))-      (const $ return (valueOf nullPtr, A.zero))+      (storableVectorNextChunk "Simple.Signal.fromStorableVectorLazy.nextChunk")+      LLVM.alloca+      (const $ return ())       ((\stable -> (stable,stable)) <$> ChunkIt.new sig)       ChunkIt.dispose @@ -236,15 +227,17 @@ compile ::    (Memory.C value, Memory.Struct value ~ struct,     Memory.C state, Memory.Struct state ~ stateStruct) =>-   (forall r z. (Phi z) => state -> MaybeCont.T r z (value, state)) ->+   (forall r z. (Phi z) => local -> state -> MaybeCont.T r z (value, state)) ->+   (forall r. CodeGenFunction r local) ->    (forall r. CodeGenFunction r state) ->    IO (Word32 -> Ptr struct -> IO Word32)-compile next start =+compile next alloca start =    Exec.compileModule $       Exec.createFunction derefFillPtr "fillsignalblock" $ \ size bPtr -> do          s <- start+         local <- alloca          (pos,_) <- MaybeCont.arrayLoop size bPtr s $ \ ptri s0 -> do-            (y,s1) <- next s0+            (y,s1) <- next local s0             MaybeCont.lift $ Memory.store y ptri             return s1          ret pos@@ -259,12 +252,13 @@ render ::    (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>    T value -> Int -> SV.Vector a-render (Cons next start createIOContext deleteIOContext) len =+render (Cons next alloca start createIOContext deleteIOContext) len =    Unsafe.performIO $    bracket createIOContext (deleteIOContext . fst) $ \ (_ioContext, params) ->    SVB.createAndTrim len $ \ ptr ->       do fill <--            compile (next $ valueTupleOf params) (start $ valueTupleOf params)+            compile+               (next $ valueTupleOf params) alloca (start $ valueTupleOf params)          fmap (fromIntegral :: Word32 -> Int) $             fill (fromIntegral len) (Memory.castStorablePtr ptr) @@ -284,13 +278,14 @@     Memory.C state, Memory.Struct state ~ stateStruct) =>    (forall r z.     (Phi z) =>-    state -> MaybeCont.T r z (value, state)) ->+    local -> state -> MaybeCont.T r z (value, state)) ->+   (forall r. CodeGenFunction r local) ->    (forall r.     CodeGenFunction r state) ->    IO (IO (Ptr stateStruct),        Exec.Finalizer stateStruct,        Ptr stateStruct -> Word32 -> Ptr struct -> IO Word32)-compileChunky next start =+compileChunky next alloca start =    Exec.compileModule $       liftA3 (,,)          (Exec.createFunction derefStartPtr "startsignal" $@@ -311,9 +306,10 @@          (Exec.createFunction derefChunkPtr "fillsignal" $           \ sptr loopLen ptr -> do              sInit <- Memory.load sptr+             local <- alloca              (pos,sExit) <- MaybeCont.arrayLoop loopLen ptr sInit $               \ ptri s0 -> do-                (y,s1) <- next s0+                (y,s1) <- next local s0                 MaybeCont.lift $ Memory.store y ptri                 return s1              Memory.store (Maybe.fromJust sExit) sptr@@ -323,11 +319,12 @@ runChunky ::    (Storable a, MakeValueTuple a, ValueTuple a ~ value, Memory.C value) =>    T value -> SVL.ChunkSize -> IO (SVL.Vector a)-runChunky (Cons next start createIOContext deleteIOContext)+runChunky (Cons next alloca start createIOContext deleteIOContext)       (SVL.ChunkSize size) = do    (ioContext, params) <- createIOContext    (startFunc, stopFunc, fill) <--      compileChunky (next $ valueTupleOf params) (start $ valueTupleOf params)+      compileChunky+         (next $ valueTupleOf params) alloca (start $ valueTupleOf params)     statePtr <- ForeignPtr.newInit stopFunc startFunc    ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext)
src/Synthesizer/LLVM/Simple/SignalPrivate.hs view
@@ -6,20 +6,28 @@ {-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Simple.SignalPrivate where +import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt+ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.MaybeContinuation as MaybeCont import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Control (ifThen, ) import LLVM.Extra.Class (MakeValueTuple, ValueTuple, ) +import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, )-import LLVM.Core (CodeGenFunction, )+import LLVM.Core (CodeGenFunction, Value, valueOf, )  import Control.Monad (liftM2, )-import Control.Applicative (Applicative, pure, liftA2, (<*>), )+import Control.Applicative (Applicative, pure, liftA2, (<*>), (<$>), )  import Foreign.Storable.Tuple () import Foreign.Storable (Storable, )+import Foreign.StablePtr (StablePtr, )+import Foreign.Ptr (Ptr, nullPtr, ) +import Data.Word (Word32, )+ import qualified Number.Ratio as Ratio import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring@@ -53,17 +61,20 @@ We can lift simple signals and processes to their parameterized counterparts. -} data T a =-   forall state ioContext parameters.+   forall state local ioContext parameters.       (Storable parameters,        MakeValueTuple parameters,        Memory.C (ValueTuple parameters),        Memory.C state) =>       Cons (forall r c.             (Phi c) =>-            ValueTuple parameters ->+            ValueTuple parameters -> local ->             state -> MaybeCont.T r c (a, state))                -- compute next value            (forall r.+            CodeGenFunction r local)+               -- allocate temporary variables before a loop+           (forall r.             ValueTuple parameters ->             CodeGenFunction r state)                -- initial state@@ -98,25 +109,35 @@       (forall r c. state -> MaybeCont.T r c (a, state)) ->       (forall r. CodeGenFunction r state) ->       signal a+   simple next start =+      simpleAlloca (\() state -> next state) (return ()) start +   simpleAlloca ::+      (Memory.C state) =>+      (forall r c. local -> state -> MaybeCont.T r c (a, state)) ->+      (forall r. CodeGenFunction r local) ->+      (forall r. CodeGenFunction r state) ->+      signal a+    alter ::-      (forall context initState exitState.-          Core context initState exitState a0 ->-          Core context initState exitState a1) ->+      (forall contextLocal initState exitState.+          Core contextLocal initState exitState a0 ->+          Core contextLocal initState exitState a1) ->       signal a0 -> signal a1  instance C T where-   simple next start =+   simpleAlloca next alloca0 start =       Cons-         (const next)+         (\() local -> next local)+         alloca0          (const start)          (return ((),()))          (const $ return ()) -   alter f (Cons next0 start0 create delete) =-      case f (Core next0 start0 id) of+   alter f (Cons next0 alloca0 start0 create delete) =+      case f (Core (uncurry next0) start0 id) of          Core next1 start1 _ ->-            Cons next1 start1 create delete+            Cons (curry next1) alloca0 start1 create delete   map ::@@ -139,13 +160,14 @@   zip :: T a -> T b -> T (a,b)-zip (Cons nextA startA createIOContextA deleteIOContextA)-    (Cons nextB startB createIOContextB deleteIOContextB) =+zip (Cons nextA allocaA startA createIOContextA deleteIOContextA)+    (Cons nextB allocaB startB createIOContextB deleteIOContextB) =    Cons-      (\(paramA, paramB) (sa0,sb0) -> do-         (a,sa1) <- nextA paramA sa0-         (b,sb1) <- nextB paramB sb0+      (\(paramA, paramB) (localA, localB) (sa0,sb0) -> do+         (a,sa1) <- nextA paramA localA sa0+         (b,sb1) <- nextB paramB localB sb0          return ((a,b), (sa1,sb1)))+      (liftM2 (,) allocaA allocaB)       (combineStart startA startB)       (combineCreate createIOContextA createIOContextB)       (combineDelete deleteIOContextA deleteIOContextB)@@ -214,3 +236,47 @@ instance (A.Field a, A.Real a, A.RationalConstant a) => P.Fractional (T a) where    fromRational x = pure (A.fromRational' x)    (/) = zipWith A.fdiv++++storableVectorNextChunk ::+   (Phi c, MakeValueTuple a, ValueTuple a ~ value,+    Memory.C value, Memory.Struct value ~ struct) =>+   String ->+   Value (StablePtr (ChunkIt.T a)) -> Value (Ptr Word32) -> () ->+   MaybeCont.T r c ((Value (Ptr struct), Value Word32), ())+storableVectorNextChunk callbackName stable lenPtr () =+   MaybeCont.fromBool $ do+      nextChunkFn <- LLVM.staticNamedFunction callbackName ChunkIt.nextCallBack+      (buffer,len) <-+         liftM2 (,)+            (LLVM.call nextChunkFn stable lenPtr)+            (LLVM.load lenPtr)+      valid <- A.cmp LLVM.CmpNE buffer (valueOf nullPtr)+      return (valid, ((buffer,len), ()))++flattenChunks ::+   (C signal, Memory.C value, Memory.Struct value ~ struct) =>+   signal (Value (Ptr struct), Value Word32) -> signal value+flattenChunks = alter $ \(Core next start stop) ->+   Core+      (\context ((buffer0,length0), state0) -> do+         ((buffer1,length1), state1) <- MaybeCont.fromBool $ do+            needNext <- A.cmp LLVM.CmpEQ length0 A.zero+            ifThen needNext+               (valueOf True, ((buffer0,length0), state0))+               (MaybeCont.toBool $ next context state0)+         MaybeCont.lift $ do+            x <- Memory.load buffer1+            buffer2 <- A.advanceArrayElementPtr buffer1+            length2 <- A.dec length1+            return (x, ((buffer2,length2), state1)))+      (\p -> (,) (valueOf nullPtr, A.zero) <$> start p)+      (stop . snd)++alloca :: (C signal, LLVM.IsSized a) => signal (LLVM.Value (Ptr a))+alloca =+   simpleAlloca+      (\ptr () -> return (ptr, ()))+      LLVM.alloca+      (return ())
synthesizer-llvm.cabal view
@@ -1,5 +1,5 @@ Name:           synthesizer-llvm-Version:        0.8+Version:        0.8.1 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -57,7 +57,7 @@   default:     True  Source-Repository this-  Tag:         0.8+  Tag:         0.8.1   Type:        darcs   Location:    http://code.haskell.org/synthesizer/llvm/