{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.Plug.Output (
T(..),
Default(..),
split,
storableVector,
) where
import qualified Synthesizer.Zip as Zip
import qualified LLVM.Extra.Multi.Value.Storable as Storable
import qualified LLVM.Extra.Multi.Value.Marshal as Marshal
import qualified LLVM.Extra.Multi.Value as MultiValue
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Core as LLVM
import Control.Applicative (liftA2)
import qualified Synthesizer.LLVM.Storable.Vector as SVU
import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB
import qualified Foreign.ForeignPtr as FPtr
import Data.Tuple.Strict (zipPair)
data T a b =
forall state ioContext parameters.
(Marshal.C parameters, Memory.C state) =>
Cons
(forall r.
MultiValue.T parameters -> a -> state -> LLVM.CodeGenFunction r state)
(forall r. MultiValue.T parameters -> LLVM.CodeGenFunction r state)
(Int -> IO (ioContext, parameters))
(Int -> ioContext -> IO b)
class Default b where
type Element b
deflt :: T (Element b) b
instance (Default c, Default d) => Default (Zip.T c d) where
type Element (Zip.T c d) = (Element c, Element d)
deflt :: T (Element (T c d)) (T c d)
deflt = T (Element c) c
-> T (Element d) d -> T (Element c, Element d) (T c d)
forall a c b d. T a c -> T b d -> T (a, b) (T c d)
split T (Element c) c
forall b. Default b => T (Element b) b
deflt T (Element d) d
forall b. Default b => T (Element b) b
deflt
split :: T a c -> T b d -> T (a,b) (Zip.T c d)
split :: forall a c b d. T a c -> T b d -> T (a, b) (T c d)
split (Cons forall r. T parameters -> a -> state -> CodeGenFunction r state
nextA forall r. T parameters -> CodeGenFunction r state
startA Int -> IO (ioContext, parameters)
createA Int -> ioContext -> IO c
deleteA)
(Cons forall r. T parameters -> b -> state -> CodeGenFunction r state
nextB forall r. T parameters -> CodeGenFunction r state
startB Int -> IO (ioContext, parameters)
createB Int -> ioContext -> IO d
deleteB) = (forall r.
T (parameters, parameters)
-> (a, b) -> (state, state) -> CodeGenFunction r (state, state))
-> (forall r.
T (parameters, parameters) -> CodeGenFunction r (state, state))
-> (Int -> IO ((ioContext, ioContext), (parameters, parameters)))
-> (Int -> (ioContext, ioContext) -> IO (T c d))
-> T (a, b) (T c d)
forall a b state ioContext parameters.
(C parameters, C state) =>
(forall r. T parameters -> a -> state -> CodeGenFunction r state)
-> (forall r. T parameters -> CodeGenFunction r state)
-> (Int -> IO (ioContext, parameters))
-> (Int -> ioContext -> IO b)
-> T a b
Cons
((T parameters
-> T parameters
-> (a, b)
-> (state, state)
-> CodeGenFunction r (state, state))
-> T (parameters, parameters)
-> (a, b)
-> (state, state)
-> CodeGenFunction r (state, state)
forall a b c. (T a -> T b -> c) -> T (a, b) -> c
MultiValue.uncurry ((T parameters
-> T parameters
-> (a, b)
-> (state, state)
-> CodeGenFunction r (state, state))
-> T (parameters, parameters)
-> (a, b)
-> (state, state)
-> CodeGenFunction r (state, state))
-> (T parameters
-> T parameters
-> (a, b)
-> (state, state)
-> CodeGenFunction r (state, state))
-> T (parameters, parameters)
-> (a, b)
-> (state, state)
-> CodeGenFunction r (state, state)
forall a b. (a -> b) -> a -> b
$ \T parameters
parameterA T parameters
parameterB (a
a,b
b) (state
sa,state
sb) ->
(state -> state -> (state, state))
-> CodeGenFunction r state
-> CodeGenFunction r state
-> CodeGenFunction r (state, state)
forall a b c.
(a -> b -> c)
-> CodeGenFunction r a
-> CodeGenFunction r b
-> CodeGenFunction r c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (T parameters -> a -> state -> CodeGenFunction r state
forall r. T parameters -> a -> state -> CodeGenFunction r state
nextA T parameters
parameterA a
a state
sa) (T parameters -> b -> state -> CodeGenFunction r state
forall r. T parameters -> b -> state -> CodeGenFunction r state
nextB T parameters
parameterB b
b state
sb))
((T parameters -> T parameters -> CodeGenFunction r (state, state))
-> T (parameters, parameters) -> CodeGenFunction r (state, state)
forall a b c. (T a -> T b -> c) -> T (a, b) -> c
MultiValue.uncurry ((T parameters -> T parameters -> CodeGenFunction r (state, state))
-> T (parameters, parameters) -> CodeGenFunction r (state, state))
-> (T parameters
-> T parameters -> CodeGenFunction r (state, state))
-> T (parameters, parameters)
-> CodeGenFunction r (state, state)
forall a b. (a -> b) -> a -> b
$ \T parameters
parameterA T parameters
parameterB ->
(state -> state -> (state, state))
-> CodeGenFunction r state
-> CodeGenFunction r state
-> CodeGenFunction r (state, state)
forall a b c.
(a -> b -> c)
-> CodeGenFunction r a
-> CodeGenFunction r b
-> CodeGenFunction r c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (T parameters -> CodeGenFunction r state
forall r. T parameters -> CodeGenFunction r state
startA T parameters
parameterA) (T parameters -> CodeGenFunction r state
forall r. T parameters -> CodeGenFunction r state
startB T parameters
parameterB))
(\Int
len -> ((ioContext, parameters)
-> (ioContext, parameters)
-> ((ioContext, ioContext), (parameters, parameters)))
-> IO (ioContext, parameters)
-> IO (ioContext, parameters)
-> IO ((ioContext, ioContext), (parameters, parameters))
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (ioContext, parameters)
-> (ioContext, parameters)
-> ((ioContext, ioContext), (parameters, parameters))
forall a b c d. (a, b) -> (c, d) -> ((a, c), (b, d))
zipPair (Int -> IO (ioContext, parameters)
createA Int
len) (Int -> IO (ioContext, parameters)
createB Int
len))
(\Int
len (ioContext
ca,ioContext
cb) -> (c -> d -> T c d) -> IO c -> IO d -> IO (T c d)
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 c -> d -> T c d
forall a b. a -> b -> T a b
Zip.Cons (Int -> ioContext -> IO c
deleteA Int
len ioContext
ca) (Int -> ioContext -> IO d
deleteB Int
len ioContext
cb))
instance (Storable.C a) => Default (SV.Vector a) where
type Element (SV.Vector a) = MultiValue.T a
deflt :: T (Element (Vector a)) (Vector a)
deflt = T (T a) (Vector a)
T (Element (Vector a)) (Vector a)
forall a. C a => T (T a) (Vector a)
storableVector
storableVector :: (Storable.C a) => T (MultiValue.T a) (SV.Vector a)
storableVector :: forall a. C a => T (T a) (Vector a)
storableVector = (forall r.
T (Ptr a) -> T a -> T (Ptr a) -> CodeGenFunction r (T (Ptr a)))
-> (forall r. T (Ptr a) -> CodeGenFunction r (T (Ptr a)))
-> (Int -> IO (Vector a, Ptr a))
-> (Int -> Vector a -> IO (Vector a))
-> T (T a) (Vector a)
forall a b state ioContext parameters.
(C parameters, C state) =>
(forall r. T parameters -> a -> state -> CodeGenFunction r state)
-> (forall r. T parameters -> CodeGenFunction r state)
-> (Int -> IO (ioContext, parameters))
-> (Int -> ioContext -> IO b)
-> T a b
Cons
(\ T (Ptr a)
_param -> (Repr (Ptr a) -> CodeGenFunction r (Repr (Ptr a)))
-> T (Ptr a) -> CodeGenFunction r (T (Ptr a))
forall (m :: * -> *) a b.
Monad m =>
(Repr a -> m (Repr b)) -> T a -> m (T b)
MultiValue.liftM ((Repr (Ptr a) -> CodeGenFunction r (Repr (Ptr a)))
-> T (Ptr a) -> CodeGenFunction r (T (Ptr a)))
-> (T a -> Repr (Ptr a) -> CodeGenFunction r (Repr (Ptr a)))
-> T a
-> T (Ptr a)
-> CodeGenFunction r (T (Ptr a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> Repr (Ptr a) -> CodeGenFunction r (Repr (Ptr a))
forall a ptr r.
(C a, Value (Ptr a) ~ ptr) =>
T a -> ptr -> CodeGenFunction r ptr
Storable.storeNext)
T (Ptr a) -> CodeGenFunction r (T (Ptr a))
forall a. a -> CodeGenFunction r a
forall r. T (Ptr a) -> CodeGenFunction r (T (Ptr a))
forall (m :: * -> *) a. Monad m => a -> m a
return
(\Int
len -> do
Vector a
vec <- Int -> (Ptr a -> IO ()) -> IO (Vector a)
forall a. Storable a => Int -> (Ptr a -> IO ()) -> IO (Vector a)
SVB.create Int
len (IO () -> Ptr a -> IO ()
forall a b. a -> b -> a
const (IO () -> Ptr a -> IO ()) -> IO () -> Ptr a -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
let (ForeignPtr a
_fp,Ptr a
ptr,Int
_l) = Vector a -> (ForeignPtr a, Ptr a, Int)
forall a. Storable a => Vector a -> (ForeignPtr a, Ptr a, Int)
SVU.unsafeToPointers Vector a
vec
(Vector a, Ptr a) -> IO (Vector a, Ptr a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector a
vec, Ptr a
ptr))
(\Int
len Vector a
vec -> do
let (ForeignPtr a
fp,Int
_s,Int
_l) = Vector a -> (ForeignPtr a, Int, Int)
forall a. Vector a -> (ForeignPtr a, Int, Int)
SVB.toForeignPtr Vector a
vec
ForeignPtr a -> IO ()
forall a. ForeignPtr a -> IO ()
FPtr.touchForeignPtr ForeignPtr a
fp
Vector a -> IO (Vector a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector a -> IO (Vector a)) -> Vector a -> IO (Vector a)
forall a b. (a -> b) -> a -> b
$ Int -> Vector a -> Vector a
forall a. Storable a => Int -> Vector a -> Vector a
SV.take Int
len Vector a
vec)