Output.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Synthesizer.LLVM.Plug.Output where

import qualified Synthesizer.Zip as Zip

import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Arithmetic as A

import qualified LLVM.Core as LLVM
import LLVM.Extra.Class (MakeValueTuple, )

import Control.Monad (liftM2, )

import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB

import qualified Foreign.Marshal.Array as Array
import qualified Foreign.ForeignPtr as FPtr
import Foreign.Storable.Tuple ()
import Foreign.Storable (Storable, )

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


data T a b =
   forall state packed size ioContext
        paramTuple paramValue paramPacked paramSize.
      (Storable paramTuple,
       MakeValueTuple paramTuple  paramValue,
       Memory.C     paramValue  paramPacked,
       LLVM.IsSized   paramPacked paramSize,
       Memory.C state packed,
       LLVM.IsSized packed size) =>
   Cons
      (forall r.
       paramValue ->
       a -> state -> LLVM.CodeGenFunction r state)
          -- compute next value
      (forall r.
       paramValue ->
       LLVM.CodeGenFunction r state)
          -- initial state
      (Int -> IO (ioContext, paramTuple))
          {- initialization from IO monad
          This is called once per output chunk
          with the number of input samples.
          This number is also the maximum possible number of output samples.
          This will be run within unsafePerformIO,
          so no observable In/Out actions please!
          -}
      (Int -> ioContext -> IO b)
          {-
          finalization from IO monad, also run within unsafePerformIO
          The integer argument is the actually produced size of data.
          We must clip the allocated output vectors accordingly.
          -}


class Default a b | b -> a where
   deflt :: T a b

instance
   (Default a c, Default b d) =>
      Default (a,b) (Zip.T c d) where
   deflt = split deflt deflt

instance
   (Storable a, MakeValueTuple a value, Memory.C value struct) =>
      Default value (SV.Vector a) where
   deflt = storableVector


split :: T a c -> T b d -> T (a,b) (Zip.T c d)
split (Cons nextA startA createA deleteA)
      (Cons nextB startB createB deleteB) = Cons
   (\(parameterA, parameterB) (a,b) (sa0,sb0) -> do
      sa1 <- nextA parameterA a sa0
      sb1 <- nextB parameterB b sb0
      return (sa1,sb1))
   (\(parameterA, parameterB) ->
      liftM2 (,)
         (startA parameterA)
         (startB parameterB))
   (\len -> do
      (ca,paramA) <- createA len
      (cb,paramB) <- createB len
      return ((ca,cb), (paramA, paramB)))
   (\len (ca,cb) ->
      liftM2 Zip.Cons
         (deleteA len ca)
         (deleteB len cb))


storableVector ::
   (Storable a, MakeValueTuple a value, Memory.C value struct) =>
   T value (SV.Vector a)
storableVector = Cons
   (\ _ a p ->
      Memory.store a p >> A.advanceArrayElementPtr p)
   return
   (\len -> do
      vec <- SVB.create len (const $ return ())
      -- s should be always zero, but we must not rely on that
      let (fp,s,_l) = SVB.toForeignPtr vec
      return (vec,
         Memory.castStorablePtr $
         FPtr.unsafeForeignPtrToPtr fp `Array.advancePtr` s))
   (\len vec -> do
      let (fp,_s,_l) = SVB.toForeignPtr vec
      -- keep the foreign ptr alive
      FPtr.touchForeignPtr fp
      return $ SV.take len vec)