knead 1.0 → 1.0.1
raw patch · 12 files changed
+760/−1102 lines, 12 filesdep ~llvm-dsldep ~llvm-extradep ~llvm-tf
Dependency ranges changed: llvm-dsl, llvm-extra, llvm-tf
Files
- knead.cabal +7/−9
- src/Data/Array/Knead/Parameter.hs +0/−3
- src/Data/Array/Knead/Parameterized/Physical.hs +0/−221
- src/Data/Array/Knead/Parameterized/PhysicalHull.hs +0/−399
- src/Data/Array/Knead/Parameterized/Private.hs +0/−218
- src/Data/Array/Knead/Parameterized/Slice.hs +0/−102
- src/Data/Array/Knead/Parameterized/Symbolic.hs +0/−93
- src/Data/Array/Knead/Symbolic/PhysicalParametric.hs +455/−0
- src/Data/Array/Knead/Symbolic/Render.hs +34/−57
- src/Data/Array/Knead/Symbolic/Render/Argument.hs +47/−0
- src/Data/Array/Knead/Symbolic/Render/Basic.hs +100/−0
- src/Data/Array/Knead/Symbolic/RenderAlt.hs +117/−0
knead.cabal view
@@ -1,5 +1,5 @@ Name: knead-Version: 1.0+Version: 1.0.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -51,7 +51,7 @@ Makefile Source-Repository this- Tag: 1.0+ Tag: 1.0.1 Type: darcs Location: https://hub.darcs.net/thielema/knead/ @@ -61,7 +61,7 @@ Library Build-Depends:- llvm-dsl >=0.1 && <0.2,+ llvm-dsl >=0.1.1 && <0.2, llvm-extra >=0.11 && <0.12, llvm-tf >=9.2 && <13.0, tfp >=1.0 && <1.1,@@ -91,14 +91,12 @@ Data.Array.Knead.Symbolic.Fold Data.Array.Knead.Symbolic.Render Other-Modules:- Data.Array.Knead.Parameter+ Data.Array.Knead.Symbolic.RenderAlt+ Data.Array.Knead.Symbolic.Render.Basic+ Data.Array.Knead.Symbolic.Render.Argument Data.Array.Knead.Symbolic.Private+ Data.Array.Knead.Symbolic.PhysicalParametric Data.Array.Knead.Symbolic.PhysicalPrivate- Data.Array.Knead.Parameterized.Private- Data.Array.Knead.Parameterized.Physical- Data.Array.Knead.Parameterized.PhysicalHull- Data.Array.Knead.Parameterized.Symbolic- Data.Array.Knead.Parameterized.Slice Data.Array.Knead.Code Data.Array.Knead.Shape.Orphan
− src/Data/Array/Knead/Parameter.hs
@@ -1,3 +0,0 @@-module Data.Array.Knead.Parameter (Param.T) where--import qualified LLVM.DSL.Parameter as Param
− src/Data/Array/Knead/Parameterized/Physical.hs
@@ -1,221 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Data.Array.Knead.Parameterized.Physical (- Phys.Array,- Array.shape,- Phys.fromList,- feed,- the,- theMarshal,- render,- renderShape,- mapAccumLSimple,- foldOuterL,- scatter,- scatterMaybe,- permute,- ) where--import qualified Data.Array.Knead.Parameterized.PhysicalHull as PhysHull-import qualified Data.Array.Knead.Parameterized.Private as Sym-import qualified Data.Array.Knead.Symbolic.Physical as Phys-import qualified Data.Array.Knead.Symbolic.Private as Core-import qualified Data.Array.Knead.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Code (getElementPtr)--import qualified Data.Array.Comfort.Storable.Unchecked as Array--import qualified LLVM.DSL.Parameter as Param-import qualified LLVM.DSL.Execution as Code-import LLVM.DSL.Expression (Exp, unExp)--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 Foreign.Marshal.Alloc (alloca, )-import Foreign.Storable (peek, )-import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, )-import Foreign.Ptr (FunPtr, Ptr, )--import Control.Exception (bracket, )-import Control.Monad.HT ((<=<), )-import Control.Applicative (liftA2, )-import Data.Tuple.HT (mapFst, )---{-# INLINE feed #-}-feed ::- (Shape.C sh, Marshal.C sh, Storable.C a) =>- Param.T p (Phys.Array sh a) -> Sym.Array p sh a-feed arr =- Param.withMulti (fmap Array.shape arr) $ \getShape valueShape ->- Sym.Array- (\p ->- case mapFst valueShape $ MultiValue.unzip p of- (sh, MultiValue.Cons ptr) ->- Core.Array (Expr.lift0 sh) $- Storable.load <=< getElementPtr sh ptr)- (\p ->- case Array.buffer $ Param.get arr p of- fptr ->- withForeignPtr fptr $ \ptr ->- return (fptr, (getShape p, ptr)))- touchForeignPtr---type Importer f = FunPtr f -> f--foreign import ccall safe "dynamic" callThe ::- Importer (LLVM.Ptr param -> Ptr a -> IO ())---the ::- (Shape.Scalar z, Storable.C a, MultiValue.C a) =>- Sym.Array p z a -> IO (p -> IO a)-the (Sym.Array arr create delete) = do- func <-- Code.compile "the" $- Code.createFunction callThe "eval" $- \paramPtr resultPtr -> do- param <- Memory.load paramPtr- case arr param of- Core.Array z code ->- code (Shape.zeroIndex z) >>=- flip Storable.store resultPtr- return $ \p ->- bracket (create p) (delete . fst) $ \(_ctx, param) ->- Marshal.with param $ \pptr ->- alloca $ \aptr -> func pptr aptr >> peek aptr--foreign import ccall safe "dynamic" callTheMarshal ::- Importer (LLVM.Ptr param -> LLVM.Ptr a -> IO ())--theMarshal ::- (Shape.Scalar z, Marshal.C a) =>- Sym.Array p z a -> IO (p -> IO a)-theMarshal (Sym.Array arr create delete) = do- func <-- Code.compile "the-marshal" $- Code.createFunction callTheMarshal "eval" $- \paramPtr resultPtr -> do- param <- Memory.load paramPtr- case arr param of- Core.Array z code ->- code (Shape.zeroIndex z) >>=- flip Memory.store resultPtr- return $ \p ->- bracket (create p) (delete . fst) $ \(_ctx, param) ->- Marshal.with param $ \pptr ->- Marshal.alloca $ \aptr ->- func pptr aptr >>- Marshal.peek aptr---foreign import ccall safe "dynamic" callShaper ::- Importer (LLVM.Ptr param -> LLVM.Ptr shape -> IO Shape.Size)---renderShape ::- (Shape.C sh, Marshal.C sh,- Storable.C a, MultiValue.C a) =>- Sym.Array p sh a -> IO (p -> IO (sh, Shape.Size))-renderShape (Sym.Array arr create delete) = do- fsh <-- Code.compile "renderShape" $- Code.createFunction callShaper "shape" $- \paramPtr resultPtr -> do- param <- Memory.load paramPtr- case arr param of- Core.Array esh _code -> do- sh <- unExp esh- Memory.store sh resultPtr- Shape.size sh- return $ \p ->- bracket (create p) (delete . fst) $ \(_ctx, param) ->- Marshal.alloca $ \shptr ->- Marshal.with param $ \pptr -> do- n <- fsh pptr shptr- sh <- Marshal.peek shptr- return (sh, n)---render ::- (Shape.C sh, Marshal.C sh, Storable.C a) =>- Sym.Array p sh a -> IO (p -> IO (Phys.Array sh a))-render = PhysHull.render . Sym.arrayHull---mapAccumLSimple ::- (Shape.C sh, Marshal.C sh,- Shape.C n, Marshal.C n,- MultiValue.C acc,- Storable.C a, MultiValue.C a,- Storable.C b, MultiValue.C b) =>- (Exp acc -> Exp a -> Exp (acc,b)) ->- Sym.Array p sh acc ->- Sym.Array p (sh, n) a ->- IO (p -> IO (Phys.Array (sh,n) b))-mapAccumLSimple f arrInit arrMap =- PhysHull.mapAccumLSimple $- liftA2 (PhysHull.MapAccumLSimple f)- (Sym.arrayHull arrInit)- (Sym.arrayHull arrMap)--foldOuterL ::- (Shape.C sh, Marshal.C sh,- Shape.C n, Marshal.C n,- Storable.C a, MultiValue.C a) =>- (Exp a -> Exp b -> Exp a) ->- Sym.Array p sh a ->- Sym.Array p (n,sh) b ->- IO (p -> IO (Phys.Array sh a))-foldOuterL f arrInit arrMap =- PhysHull.foldOuterL $- liftA2 (PhysHull.FoldOuterL f)- (Sym.arrayHull arrInit)- (Sym.arrayHull arrMap)--scatter ::- (Shape.C sh0, Shape.Index sh0 ~ ix0,- Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,- Storable.C a, MultiValue.C a) =>- (Exp a -> Exp a -> Exp a) ->- Sym.Array p sh1 a ->- Sym.Array p sh0 (ix1, a) -> IO (p -> IO (Phys.Array sh1 a))-scatter accum arrBase arrMap =- PhysHull.scatter $- liftA2 (PhysHull.Scatter accum)- (Sym.arrayHull arrBase)- (Sym.arrayHull arrMap)--scatterMaybe ::- (Shape.C sh0, Shape.Index sh0 ~ ix0,- Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,- Storable.C a, MultiValue.C a) =>- (Exp a -> Exp a -> Exp a) ->- Sym.Array p sh1 a ->- Sym.Array p sh0 (Maybe (ix1, a)) -> IO (p -> IO (Phys.Array sh1 a))-scatterMaybe accum arrBase arrMap =- PhysHull.scatterMaybe $- liftA2 (PhysHull.ScatterMaybe accum)- (Sym.arrayHull arrBase)- (Sym.arrayHull arrMap)--permute ::- (Shape.C sh0, Shape.Index sh0 ~ ix0,- Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,- Storable.C a, MultiValue.C a) =>- (Exp a -> Exp a -> Exp a) ->- Sym.Array p sh1 a ->- (Exp ix0 -> Exp ix1) ->- Sym.Array p sh0 a ->- IO (p -> IO (Phys.Array sh1 a))-permute accum deflt ixmap input =- scatter accum deflt- (Core.mapWithIndex (Expr.lift2 MultiValue.zip . ixmap) input)
− src/Data/Array/Knead/Parameterized/PhysicalHull.hs
@@ -1,399 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Data.Array.Knead.Parameterized.PhysicalHull (- render,- MapFilter(..),- mapFilter,- FilterOuter(..),- filterOuter,- Scatter(..),- scatter,- ScatterMaybe(..),- scatterMaybe,- MapAccumLSimple(..),- mapAccumLSimple,- MapAccumLSequence(..),- mapAccumLSequence,- MapAccumL(..),- mapAccumL,- FoldOuterL(..),- foldOuterL,- AddDimension(..),- addDimension,- ) where--import qualified Data.Array.Knead.Parameterized.Private as Sym-import qualified Data.Array.Knead.Symbolic.PhysicalPrivate as Priv-import qualified Data.Array.Knead.Symbolic.Private as Core-import qualified Data.Array.Knead.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Symbolic.PhysicalPrivate (MarshalPtr)--import Data.Array.Comfort.Storable.Unchecked (Array(Array))--import qualified LLVM.DSL.Execution as Code-import LLVM.DSL.Expression (Exp, unExp)--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.Extra.Arithmetic as A--import qualified LLVM.Core as LLVM--import Foreign.Marshal.Array (allocaArray, )-import Foreign.Marshal.Alloc (alloca, )-import Foreign.Storable (Storable, peek, peekElemOff, )-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray, )-import Foreign.Ptr (FunPtr, Ptr, )--import Control.Exception (bracket, )-import Control.Monad.HT (void, )-import Control.Applicative (liftA2, )---mallocArray :: (Storable a) => Shape.Size -> IO (ForeignPtr a)-mallocArray = mallocForeignPtrArray . fromIntegral---type Importer f = FunPtr f -> f---foreign import ccall safe "dynamic" callShaper ::- Importer (LLVM.Ptr param -> LLVM.Ptr shape -> IO Shape.Size)--foreign import ccall safe "dynamic" callFill ::- Importer (LLVM.Ptr param -> LLVM.Ptr shape -> Ptr a -> IO ())---{--Attention:-The 'fill' function may alter the shape.-An example is 'mapFilter'.--}-materialize ::- (Shape.C sh, Marshal.C sh, Storable.C a) =>- String ->- (core -> Exp sh) ->- (core ->- LLVM.Value (MarshalPtr sh) -> LLVM.Value (Ptr a) ->- LLVM.CodeGenFunction () ()) ->- Sym.Hull p core -> IO (p -> IO (Array sh a))-materialize name shape fill (Sym.Hull core create delete) = do- (fsh, farr) <-- Code.compile name $- liftA2 (,)- (Code.createFunction callShaper "shape" $- \paramPtr resultPtr -> do- param <- Memory.load paramPtr- sh <- unExp $ shape $ core param- Memory.store sh resultPtr- Shape.size sh)- (Code.createFunction callFill "fill" $- \paramPtr shapePtr bufferPtr -> do- param <- Memory.load paramPtr- fill (core param) shapePtr bufferPtr)-- return $ \p ->- bracket (create p) (delete . fst) $ \(_ctx, param) ->- Marshal.alloca $ \shptr ->- Marshal.with param $ \paramPtr -> do- fptr <- mallocArray =<< fsh paramPtr shptr- withForeignPtr fptr $ farr paramPtr shptr- sh <- Marshal.peek shptr- return (Array sh fptr)---foreign import ccall safe "dynamic" callFillExpArray ::- Importer (LLVM.Ptr param -> Ptr final -> LLVM.Ptr shape -> Ptr a -> IO ())---materializeExpArray ::- (Shape.C sh, Marshal.C sh, Storable.C a, Storable.C b) =>- String ->- (core -> Exp sh) ->- (core ->- LLVM.Value (Ptr b) ->- LLVM.Value (MarshalPtr sh) ->- LLVM.Value (Ptr a) ->- LLVM.CodeGenFunction () ()) ->- Sym.Hull p core -> IO (p -> IO (b, Array sh a))-materializeExpArray name shape fill (Sym.Hull core create delete) = do- (fsh, farr) <-- Code.compile name $- liftA2 (,)- (Code.createFunction callShaper "shape" $- \paramPtr resultPtr -> do- param <- Memory.load paramPtr- sh <- unExp $ shape $ core param- Memory.store sh resultPtr- Shape.size sh)- (Code.createFunction callFillExpArray "fill" $- \paramPtr finalPtr shapePtr bufferPtr -> do- param <- Memory.load paramPtr- fill (core param) finalPtr shapePtr bufferPtr)-- return $ \p ->- bracket (create p) (delete . fst) $ \(_ctx, param) ->- Marshal.alloca $ \shptr ->- alloca $ \finalPtr ->- Marshal.with param $ \paramPtr -> do- fptr <- mallocArray =<< fsh paramPtr shptr- withForeignPtr fptr $ farr paramPtr finalPtr shptr- sh <- Marshal.peek shptr- final <- peek finalPtr- return (final, Array sh fptr)---foreign import ccall safe "dynamic" callShaper2 ::- Importer- (LLVM.Ptr param ->- LLVM.Ptr shapeA -> LLVM.Ptr shapeB -> Ptr Shape.Size -> IO ())--foreign import ccall safe "dynamic" callFill2 ::- Importer- (LLVM.Ptr param ->- LLVM.Ptr shapeA -> Ptr a -> LLVM.Ptr shapeB -> Ptr b -> IO ())---materialize2 ::- (Shape.C sha, Marshal.C sha,- Shape.C shb, Marshal.C shb,- Storable.C a, Storable.C b) =>- String ->- (core -> Exp (sha,shb)) ->- (core ->- (LLVM.Value (MarshalPtr sha), LLVM.Value (Ptr a)) ->- (LLVM.Value (MarshalPtr shb), LLVM.Value (Ptr b)) ->- LLVM.CodeGenFunction () ()) ->- Sym.Hull p core -> IO (p -> IO (Array sha a, Array shb b))-materialize2 name shape fill (Sym.Hull core create delete) = do- (fsh, farr) <-- Code.compile name $- liftA2 (,)- (Code.createFunction callShaper2 "shape" $- \paramPtr shapeAPtr shapeBPtr sizesPtr -> do- param <- Memory.load paramPtr- (sha,shb) <- fmap MultiValue.unzip $ unExp $ shape $ core param- Memory.store sha shapeAPtr- Memory.store shb shapeBPtr- sizeAPtr <- LLVM.bitcast sizesPtr- flip LLVM.store sizeAPtr =<< Shape.size sha- sizeBPtr <- A.advanceArrayElementPtr sizeAPtr- flip LLVM.store sizeBPtr =<< Shape.size shb)- (Code.createFunction callFill2 "fill" $- \paramPtr shapeAPtr bufferAPtr shapeBPtr bufferBPtr -> do- param <- Memory.load paramPtr- fill (core param) (shapeAPtr, bufferAPtr) (shapeBPtr, bufferBPtr))-- return $ \p ->- bracket (create p) (delete . fst) $ \(_ctx, param) ->- Marshal.alloca $ \shaPtr ->- Marshal.alloca $ \shbPtr ->- allocaArray 2 $ \sizesPtr ->- Marshal.with param $ \paramPtr -> do- fsh paramPtr shaPtr shbPtr sizesPtr- afptr <- mallocArray =<< peekElemOff sizesPtr 0- bfptr <- mallocArray =<< peekElemOff sizesPtr 1- withForeignPtr afptr $ \aptr ->- withForeignPtr bfptr $ \bptr ->- farr paramPtr shaPtr aptr shbPtr bptr- sha <- Marshal.peek shaPtr- shb <- Marshal.peek shbPtr- return (Array sha afptr, Array shb bfptr)---render ::- (Shape.C sh, Shape.Index sh ~ ix, Marshal.C sh,- Storable.C a) =>- Sym.Hull p (Core.Array sh a) -> IO (p -> IO (Array sh a))-render =- materialize "render" Core.shape- (\(Core.Array esh code) shapePtr bufferPtr -> do- let step ix p = flip Storable.storeNext p =<< code ix- sh <- Shape.load esh shapePtr- void $ Shape.loop step sh bufferPtr)---data Scatter sh0 sh1 a =- Scatter {- scatterAccum :: Exp a -> Exp a -> Exp a,- scatterInit :: Core.Array sh1 a,- scatterMap :: Core.Array sh0 (Shape.Index sh1, a)- }--scatter ::- (Shape.C sh0, Shape.Index sh0 ~ ix0,- Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,- Storable.C a) =>- Sym.Hull p (Scatter sh0 sh1 a) -> IO (p -> IO (Array sh1 a))-scatter =- materialize "scatter"- (Core.shape . scatterInit)- (\(Scatter accum arrInit arrMap) ->- Priv.scatter accum arrInit arrMap)----data ScatterMaybe sh0 sh1 a =- ScatterMaybe {- scatterMaybeAccum :: Exp a -> Exp a -> Exp a,- scatterMaybeInit :: Core.Array sh1 a,- scatterMaybeMap :: Core.Array sh0 (Maybe (Shape.Index sh1, a))- }--scatterMaybe ::- (Shape.C sh0, Shape.Index sh0 ~ ix0,- Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,- Storable.C a) =>- Sym.Hull p (ScatterMaybe sh0 sh1 a) -> IO (p -> IO (Array sh1 a))-scatterMaybe =- materialize "scatterMaybe"- (Core.shape . scatterMaybeInit)- (\(ScatterMaybe accum arrInit arrMap) ->- Priv.scatterMaybe accum arrInit arrMap)---data MapAccumLSimple sh n acc a b =- MapAccumLSimple {- mapAccumLSimpleAccum :: Exp acc -> Exp a -> Exp (acc,b),- mapAccumLSimpleInit :: Core.Array sh acc,- mapAccumLSimpleArray :: Core.Array (sh, n) a- }--mapAccumLSimple ::- (Shape.C sh, Marshal.C sh,- Shape.C n, Marshal.C n,- MultiValue.C acc, Storable.C a, Storable.C b) =>- Sym.Hull p (MapAccumLSimple sh n acc a b) -> IO (p -> IO (Array (sh,n) b))-mapAccumLSimple =- materialize "mapAccumLSimple"- (Core.shape . mapAccumLSimpleArray)- (\(MapAccumLSimple f arrInit arrData) ->- Priv.mapAccumLSimple f arrInit arrData)---data MapAccumLSequence n acc final a b =- MapAccumLSequence {- mapAccumLSequenceAccum :: Exp acc -> Exp a -> Exp (acc,b),- mapAccumLSequenceFinal :: Exp acc -> Exp final,- mapAccumLSequenceInit :: Exp acc,- mapAccumLSequenceArray :: Core.Array n a- }---- FIXME: check correct size of array of initial values-mapAccumLSequence ::- (Shape.C n, Marshal.C n, MultiValue.C acc,- Storable.C final, MultiValue.C final,- Storable.C a, Storable.C b) =>- Sym.Hull p (MapAccumLSequence n acc final a b) ->- IO (p -> IO (final, Array n b))-mapAccumLSequence =- materializeExpArray "mapAccumLSequence"- (Core.shape . mapAccumLSequenceArray)- (\(MapAccumLSequence f final expInit arr) ->- Priv.mapAccumLSequence f final expInit arr)---data MapAccumL sh n acc final a b =- MapAccumL {- mapAccumLAccum :: Exp acc -> Exp a -> Exp (acc,b),- mapAccumLFinal :: Exp acc -> Exp final,- mapAccumLInit :: Core.Array sh acc,- mapAccumLArray :: Core.Array (sh, n) a- }---- FIXME: check correct size of array of initial values-mapAccumL ::- (Shape.C sh, Marshal.C sh,- Shape.C n, Marshal.C n,- MultiValue.C acc,- Storable.C final, MultiValue.C final,- Storable.C a, Storable.C b) =>- Sym.Hull p (MapAccumL sh n acc final a b) ->- IO (p -> IO (Array sh final, Array (sh,n) b))-mapAccumL =- materialize2 "mapAccumL"- (\core ->- Expr.zip- (Core.shape $ mapAccumLInit core)- (Core.shape $ mapAccumLArray core))- (\(MapAccumL f final arrInit arrData) ->- Priv.mapAccumL f final arrInit arrData)---data FoldOuterL n sh a b =- FoldOuterL {- foldOuterLAccum :: Exp a -> Exp b -> Exp a,- foldOuterLInit :: Core.Array sh a,- foldOuterLArray :: Core.Array (n,sh) b- }---- FIXME: check correct size of array of initial values-foldOuterL ::- (Shape.C n, Marshal.C n,- Shape.C sh, Marshal.C sh,- Storable.C a) =>- Sym.Hull p (FoldOuterL n sh a b) -> IO (p -> IO (Array sh a))-foldOuterL =- materialize "foldOuterL"- (Core.shape . foldOuterLInit)- (\(FoldOuterL f arrInit arrData) -> Priv.foldOuterL f arrInit arrData)---data MapFilter n a b =- MapFilter {- mapFilterMap :: Exp a -> Exp b,- mapFilterPredicate :: Exp a -> Exp Bool,- mapFilterArray :: Core.Array n a- }--mapFilter ::- (Shape.Sequence n, Marshal.C n, Storable.C b) =>- Sym.Hull p (MapFilter n a b) -> IO (p -> IO (Array n b))-mapFilter =- materialize "mapFilter"- (Core.shape . mapFilterArray)- (\(MapFilter f p arr) shapePtr bufferPtr ->- flip Memory.store shapePtr- =<< Priv.mapFilter f p arr shapePtr bufferPtr)---data FilterOuter n sh a =- FilterOuter {- filterOuterPredicate :: Core.Array n Bool,- filterOuterArray :: Core.Array (n,sh) a- }---- FIXME: check correct size of row selection array-filterOuter ::- (Shape.Sequence n, Marshal.C n,- Shape.C sh, Marshal.C sh,- Storable.C a) =>- Sym.Hull p (FilterOuter n sh a) -> IO (p -> IO (Array (n,sh) a))-filterOuter =- materialize "filterOuter"- (Core.shape . filterOuterArray)- (\(FilterOuter p arr) shapePtr bufferPtr ->- flip Memory.store shapePtr- =<< Priv.filterOuter p arr shapePtr bufferPtr)---data AddDimension sh n a b =- AddDimension {- addDimensionSize :: Exp n,- addDimensionSelect :: Exp (Shape.Index n) -> Exp a -> Exp b,- addDimensionArray :: Core.Array sh a- }--addDimension ::- (Shape.C sh, Marshal.C sh,- Shape.C n, Marshal.C n,- Storable.C b) =>- Sym.Hull p (AddDimension sh n a b) -> IO (p -> IO (Array (sh,n) b))-addDimension =- materialize "addDimension"- (\r -> Expr.zip (Core.shape (addDimensionArray r)) (addDimensionSize r))- (\(AddDimension n select arr) -> Priv.addDimension n select arr)
− src/Data/Array/Knead/Parameterized/Private.hs
@@ -1,218 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-module Data.Array.Knead.Parameterized.Private where--import qualified Data.Array.Knead.Symbolic as Core--import qualified Data.Array.Knead.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, )--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.Multi.Value.Marshal as Marshal-import qualified LLVM.Extra.Multi.Value as MultiValue--import Control.Monad (liftM2)-import Control.Applicative (Applicative (pure, (<*>)), )--import Data.Tuple.Strict (zipPair)--import Prelude2010 hiding (id, map, zipWith, replicate)-import Prelude ()------ in principle we could define Array in terms of Hull and Core.Array-data Array p sh a =- forall parameter context.- (Marshal.C parameter) =>- Array {- core :: MultiValue.T parameter -> Core.Array sh a,- createContext :: p -> IO (context, parameter),- deleteContext :: context -> IO ()- }--instance Core.C (Array p) where- lift0 arr = Array (const arr) (createPlain (const ())) deletePlain- lift1 f (Array arr create delete) = Array (f . arr) create delete- lift2 f (Array arrA createA deleteA) (Array arrB createB deleteB) =- Array- (MultiValue.uncurry $ \paramA paramB ->- f (arrA paramA) (arrB paramB))- (combineCreate createA createB)- (combineDelete deleteA deleteB)---(!) ::- (Shape.C sh, Shape.Index sh ~ ix, Marshal.C ix,- Shape.Scalar z) =>- Array p sh a -> Param.T p ix -> Array p z a-(!) arr pix =- runHull $- mapHullWithExp- (\ix carr -> Core.fromScalar $ carr Core.! ix)- (expParam pix)- (arrayHull arr)---fill ::- (Shape.C sh, Marshal.C sh, Marshal.C a) =>- Param.T p sh -> Param.T p a -> Array p sh a-fill sh a =- Shape.paramWith sh $ \getSh valueSh ->- Param.withMulti a $ \getA valueA ->- Array- (MultiValue.uncurry $ \vsh va ->- Core.fill (valueSh vsh) (Expr.lift0 $ valueA va))- (createPlain $ \p -> (getSh p, getA p))- deletePlain--gather ::- (Shape.C sh0, Shape.Index sh0 ~ ix0,- Shape.C sh1, MultiValue.C a) =>- Array p sh1 ix0 ->- Array p sh0 a ->- Array p sh1 a-gather = Core.gather---id ::- (Shape.C sh, Marshal.C sh, Shape.Index sh ~ ix) =>- Param.T p sh -> Array p sh ix-id sh =- Shape.paramWith sh $ \getSh valueSh ->- Array- (Core.id . valueSh)- (createPlain getSh)- deletePlain--map ::- (Shape.C sh, Marshal.C c) =>- (Exp c -> Exp a -> Exp b) ->- Param.T p c -> Array p sh a -> Array p sh b-map = lift Core.map--mapWithIndex ::- (Shape.C sh, Marshal.C c, Shape.Index sh ~ ix) =>- (Exp c -> Exp ix -> Exp a -> Exp b) ->- Param.T p c -> Array p sh a -> Array p sh b-mapWithIndex = lift Core.mapWithIndex---fold1 ::- (Shape.C sh0, Shape.C sh1, Marshal.C c, MultiValue.C a) =>- (Exp c -> Exp a -> Exp a -> Exp a) ->- Param.T p c -> Array p (sh0, sh1) a -> Array p sh0 a-fold1 = lift Core.fold1--fold1All ::- (Shape.C sh, Shape.Scalar z, Marshal.C c, MultiValue.C a) =>- (Exp c -> Exp a -> Exp a -> Exp a) ->- Param.T p c -> Array p sh a -> Array p z a-fold1All = lift (\p -> Core.fill Shape.scalar . Core.fold1All p)--lift ::- (Shape.C sh0, Shape.C sh1, Marshal.C c) =>- (f -> Core.Array sh0 a -> Core.Array sh1 b) ->- (Exp c -> f) ->- Param.T p c -> Array p sh0 a -> Array p sh1 b-lift g f c arr =- runHull $- mapHullWithExp- (\cexp -> g (f cexp))- (expParam c)- (arrayHull arr)---data Hull p a =- forall parameter context.- (Marshal.C parameter) =>- Hull {- hullCore :: MultiValue.T parameter -> a,- hullCreateContext :: p -> IO (context, parameter),- hullDeleteContext :: context -> IO ()- }--instance Functor (Hull p) where- fmap f (Hull arr create delete) = Hull (f . arr) create delete--instance Applicative (Hull p) where- pure a = Hull (const a) (const $ return ((),())) return- Hull arrA createA deleteA <*> Hull arrB createB deleteB =- Hull- (MultiValue.uncurry $ \a b -> arrA a $ arrB b)- (combineCreate createA createB)- (combineDelete deleteA deleteB)--{- |-Equivalent to @liftA2 f (expHull p)@ but saves us an empty context.--}-mapHullWithExp ::- (Exp sl -> a -> b) ->- Param.Tunnel p sl -> Hull p a -> Hull p b-mapHullWithExp f tunnel (Hull arr create delete) =- case tunnel of- Param.Tunnel getSl valueSl ->- Hull- (MultiValue.uncurry $ \arrp sl ->- f (Expr.lift0 $ valueSl sl) $ arr arrp)- (\p -> do- (ctx, param) <- create p- return (ctx, (param, getSl p)))- delete--expHull :: Param.Tunnel p sl -> Hull p (Exp sl)-expHull tunnel =- case tunnel of- Param.Tunnel getSl valueSl ->- Hull- (Expr.lift0 . valueSl)- (\p -> return ((), getSl p))- return--arrayHull :: Array p sh a -> Hull p (Core.Array sh a)-arrayHull (Array arr create delete) = Hull arr create delete--runHull :: Hull p (Core.Array sh a) -> Array p sh a-runHull (Hull arr create delete) = Array arr create delete--extendHull :: (q -> p) -> Hull p a -> Hull q a-extendHull f (Hull arr create delete) = Hull arr (create . f) delete----expParam :: (Marshal.C a) => Param.T p a -> Param.Tunnel p a-expParam = Param.tunnel MultiValue.cons----createPlain :: (Monad m) => (p -> pl) -> p -> m ((), pl)-createPlain f p = return ((), f p)--deletePlain :: (Monad m) => () -> m ()-deletePlain () = return ()---{-# INLINE combineCreate #-}-combineCreate ::- Monad m =>- (p -> m (ctxA, paramA)) -> (p -> m (ctxB, paramB)) ->- p -> m ((ctxA, ctxB), (paramA, paramB))-combineCreate createA createB p =- liftM2 zipPair (createA p) (createB p)--{-# INLINE combineDelete #-}-combineDelete ::- Monad m =>- (ctxA -> m ()) -> (ctxB -> m ()) -> (ctxA, ctxB) -> m ()-combineDelete deleteA deleteB (ctxA, ctxB) = do- deleteA ctxA- deleteB ctxB---extendParameter ::- (q -> p) -> Array p sh a -> Array q sh a-extendParameter f (Array arr create delete) =- Array arr (create . f) delete
− src/Data/Array/Knead/Parameterized/Slice.hs
@@ -1,102 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeOperators #-}-module Data.Array.Knead.Parameterized.Slice (- T,- apply,- Cubic,- passAny,- pass,- pick,- extrude,- (Core.$:.),- ) where--import qualified Data.Array.Knead.Parameterized.Private as Priv-import Data.Array.Knead.Parameterized.Private (Array(Array), )--import qualified Data.Array.Knead.Symbolic.Slice as Slice-import qualified Data.Array.Knead.Symbolic.Private as Core--import qualified Data.Array.Knead.Shape.Cubic.Int as Index-import qualified Data.Array.Knead.Shape.Cubic as Cubic-import qualified Data.Array.Knead.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, )--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.Multi.Value.Marshal as Marshal-import qualified LLVM.Extra.Multi.Value as MultiValue--import qualified Type.Data.Num.Unary as Unary---{--This wrapper data type is pretty much the same as Parameterized.Array-but there seems to be no benefit from using the same data structure for it.--}-data T p sh0 sh1 =- forall parameter context.- (Marshal.C parameter) =>- Cons {- _core :: MultiValue.T parameter -> Slice.T sh0 sh1,- _createContext :: p -> IO (context, parameter),- _deleteContext :: context -> IO ()- }--apply ::- (Shape.C sh0, Shape.C sh1, MultiValue.C a) =>- T p sh0 sh1 ->- Array p sh0 a ->- Array p sh1 a-apply (Cons slice createSlice deleteSlice) (Array arr createArr deleteArr) =- Array- (MultiValue.uncurry $ \paramSlice paramArr ->- Slice.apply (slice paramSlice) (arr paramArr))- (Priv.combineCreate createSlice createArr)- (Priv.combineDelete deleteSlice deleteArr)---type Cubic p rank0 rank1 = T p (Cubic.Shape rank0) (Cubic.Shape rank1)---passAny :: Cubic p rank rank-passAny =- Cons (const Slice.passAny) (Priv.createPlain $ const ()) Priv.deletePlain--pass ::- (Unary.Natural rank0, Unary.Natural rank1) =>- Cubic p rank0 rank1 ->- Cubic p (Unary.Succ rank0) (Unary.Succ rank1)-pass (Cons slice create delete) = Cons (Slice.pass . slice) create delete--pick ::- (Unary.Natural rank0, Unary.Natural rank1) =>- Param.T p Index.Int ->- Cubic p rank0 rank1 ->- Cubic p (Unary.Succ rank0) rank1-pick = lift Slice.pick--extrude ::- (Unary.Natural rank0, Unary.Natural rank1) =>- Param.T p Index.Int ->- Cubic p rank0 rank1 ->- Cubic p rank0 (Unary.Succ rank1)-extrude = lift Slice.extrude--lift ::- (Marshal.C i) =>- (Exp i -> Slice.Cubic rank0 rank1 -> Slice.Cubic rank2 rank3) ->- Param.T p i ->- Cubic p rank0 rank1 -> Cubic p rank2 rank3-lift f i (Cons slice create delete) =- Param.withMulti i $ \getI valueI ->- Cons- (MultiValue.uncurry $ \slicep ip ->- f (Expr.lift0 (valueI ip)) (slice slicep))- (\p -> do- (ctx, param) <- create p- return (ctx, (param, getI p)))- delete--instance Core.Process (T p sh0 sh1) where
− src/Data/Array/Knead/Parameterized/Symbolic.hs
@@ -1,93 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}-module Data.Array.Knead.Parameterized.Symbolic (- Array,- Exp,- Sym.extendParameter,- withExp,- withExp2,- withExp3,- (Sym.!),- Sym.fill,- gather,- backpermute,- Sym.id,- Sym.map,- zipWith,- Sym.fold1,- Sym.fold1All,- ) where--import qualified Data.Array.Knead.Parameterized.Private as Sym-import qualified Data.Array.Knead.Symbolic as Core-import Data.Array.Knead.Parameterized.Private (Array, gather, )--import qualified Data.Array.Knead.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, )--import qualified LLVM.DSL.Parameter as Param--import qualified LLVM.Extra.Multi.Value.Marshal as Marshal-import qualified LLVM.Extra.Multi.Value as MultiValue--import Control.Applicative ((<*>), )--import Prelude (uncurry, ($), (.), )---{--fromScalar ::- (Storable a, MultiValueMemory.C a, MultiValue.C a) =>- Param.T p a -> Array p Z a-fromScalar = Sym.fill (return Z)--}---backpermute ::- (Shape.C sh0, Shape.Index sh0 ~ ix0,- Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,- MultiValue.C a) =>- Param.T p sh1 ->- (Exp ix1 -> Exp ix0) ->- Array p sh0 a ->- Array p sh1 a-backpermute sh1 f = gather (Core.map f (Sym.id sh1))---zipWith ::- (Shape.C sh, Marshal.C d) =>- (Exp d -> Exp a -> Exp b -> Exp c) ->- Param.T p d -> Array p sh a -> Array p sh b -> Array p sh c-zipWith f d a b =- Sym.map (\di ab -> uncurry (f di) $ Expr.unzip ab) d $ Core.zip a b---withExp ::- (Marshal.C x) =>- (Exp x -> Core.Array shb b -> Core.Array sha a) ->- Param.T p x -> Array p shb b -> Array p sha a-withExp f x =- Sym.runHull . Sym.mapHullWithExp f (Sym.expParam x) . Sym.arrayHull--withExp2 ::- (Marshal.C x) =>- (Exp x -> Core.Array sha a -> Core.Array shb b -> Core.Array shc c) ->- Param.T p x -> Array p sha a -> Array p shb b -> Array p shc c-withExp2 f x a b =- Sym.runHull $- Sym.mapHullWithExp f (Sym.expParam x) (Sym.arrayHull a)- <*> Sym.arrayHull b--withExp3 ::- (Marshal.C x) =>- (Exp x -> Core.Array sha a ->- Core.Array shb b -> Core.Array shc c -> Core.Array shd d) ->- Param.T p x -> Array p sha a ->- Array p shb b -> Array p shc c -> Array p shd d-withExp3 f x a b c =- Sym.runHull $- Sym.mapHullWithExp f (Sym.expParam x) (Sym.arrayHull a)- <*> Sym.arrayHull b- <*> Sym.arrayHull c
+ src/Data/Array/Knead/Symbolic/PhysicalParametric.hs view
@@ -0,0 +1,455 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Data.Array.Knead.Symbolic.PhysicalParametric (+ the,+ theMarshal,+ render,+ MapFilter(..),+ mapFilter,+ FilterOuter(..),+ filterOuter,+ Scatter(..),+ scatter,+ ScatterMaybe(..),+ scatterMaybe,+ MapAccumLSimple(..),+ mapAccumLSimple,+ MapAccumLSequence(..),+ mapAccumLSequence,+ MapAccumL(..),+ mapAccumL,+ FoldOuterL(..),+ foldOuterL,+ AddDimension(..),+ addDimension,++ Parametric,+ Rendered,+ ) where++import qualified Data.Array.Knead.Symbolic.PhysicalPrivate as Priv+import qualified Data.Array.Knead.Symbolic.Private as Core+import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Symbolic.PhysicalPrivate (MarshalPtr)++import Data.Array.Comfort.Storable.Unchecked (Array(Array))++import qualified LLVM.DSL.Execution as Code+import LLVM.DSL.Expression (Exp(Exp), unExp)++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.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM++import Foreign.Marshal.Array (allocaArray, )+import Foreign.Marshal.Alloc (alloca, )+import Foreign.Storable (Storable, peek, peekElemOff, )+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray, )+import Foreign.Ptr (FunPtr, Ptr, )++import Control.Exception (finally)+import Control.Monad.HT (void, )+import Control.Applicative (liftA2, )+++mallocArray :: (Storable a) => Shape.Size -> IO (ForeignPtr a)+mallocArray = mallocForeignPtrArray . fromIntegral+++type Importer f = FunPtr f -> f+++++type Parametric p a = Exp p -> a+type Rendered p a = IO (p, IO ()) -> IO a++withManagedParam :: Monad m => (p -> IO a) -> m (Rendered p a)+withManagedParam act =+ return $ \create -> do+ (param, final) <- create+ finally (act param) final++++foreign import ccall safe "dynamic" callThe ::+ Importer (LLVM.Ptr param -> Ptr a -> IO ())++the ::+ (Marshal.C p, Shape.Scalar z, Storable.C a) =>+ Parametric p (Core.Array z a) -> IO (Rendered p a)+the arr = do+ func <-+ Code.compile "the" $+ Code.createFunction callThe "eval" $+ \paramPtr resultPtr -> do+ case arr $ Exp (Memory.load paramPtr) of+ Core.Array z code ->+ code (Shape.zeroIndex z) >>=+ flip Storable.store resultPtr+ withManagedParam $ \param ->+ Marshal.with param $ \pptr ->+ alloca $ \aptr -> func pptr aptr >> peek aptr++foreign import ccall safe "dynamic" callTheMarshal ::+ Importer (LLVM.Ptr param -> LLVM.Ptr a -> IO ())++theMarshal ::+ (Marshal.C p, Shape.Scalar z, Marshal.C a) =>+ Parametric p (Core.Array z a) -> IO (Rendered p a)+theMarshal arr = do+ func <-+ Code.compile "the-marshal" $+ Code.createFunction callTheMarshal "eval" $+ \paramPtr resultPtr -> do+ case arr $ Exp (Memory.load paramPtr) of+ Core.Array z code ->+ code (Shape.zeroIndex z) >>=+ flip Memory.store resultPtr+ withManagedParam $ \param ->+ Marshal.with param $ \pptr ->+ Marshal.alloca $ \aptr ->+ func pptr aptr >>+ Marshal.peek aptr+++++foreign import ccall safe "dynamic" callShaper ::+ Importer (LLVM.Ptr param -> LLVM.Ptr shape -> IO Shape.Size)++foreign import ccall safe "dynamic" callFill ::+ Importer (LLVM.Ptr param -> LLVM.Ptr shape -> Ptr a -> IO ())+++{-+Attention:+The 'fill' function may alter the shape.+An example is 'mapFilter'.+-}+materialize ::+ (Shape.C sh, Marshal.C sh, Marshal.C p, Storable.C a) =>+ String ->+ (core -> Exp sh) ->+ (core ->+ LLVM.Value (MarshalPtr sh) -> LLVM.Value (Ptr a) ->+ LLVM.CodeGenFunction () ()) ->+ Parametric p core -> IO (Rendered p (Array sh a))+materialize name shape fill core = do+ (fsh, farr) <-+ Code.compile name $+ liftA2 (,)+ (Code.createFunction callShaper "shape" $+ \paramPtr resultPtr -> do+ sh <- unExp $ shape $ core $ Exp (Memory.load paramPtr)+ Memory.store sh resultPtr+ Shape.size sh)+ (Code.createFunction callFill "fill" $+ \paramPtr shapePtr bufferPtr ->+ fill (core $ Exp (Memory.load paramPtr)) shapePtr bufferPtr)++ withManagedParam $ \param ->+ Marshal.alloca $ \shptr ->+ Marshal.with param $ \paramPtr -> do+ fptr <- mallocArray =<< fsh paramPtr shptr+ withForeignPtr fptr $ farr paramPtr shptr+ sh <- Marshal.peek shptr+ return (Array sh fptr)+++foreign import ccall safe "dynamic" callFillExpArray ::+ Importer (LLVM.Ptr param -> Ptr final -> LLVM.Ptr shape -> Ptr a -> IO ())+++materializeExpArray ::+ (Shape.C sh, Marshal.C sh, Marshal.C p, Storable.C a, Storable.C b) =>+ String ->+ (core -> Exp sh) ->+ (core ->+ LLVM.Value (Ptr b) ->+ LLVM.Value (MarshalPtr sh) ->+ LLVM.Value (Ptr a) ->+ LLVM.CodeGenFunction () ()) ->+ Parametric p core -> IO (Rendered p (b, Array sh a))+materializeExpArray name shape fill core = do+ (fsh, farr) <-+ Code.compile name $+ liftA2 (,)+ (Code.createFunction callShaper "shape" $+ \paramPtr resultPtr -> do+ sh <- unExp $ shape $ core $ Exp (Memory.load paramPtr)+ Memory.store sh resultPtr+ Shape.size sh)+ (Code.createFunction callFillExpArray "fill" $+ \paramPtr finalPtr shapePtr bufferPtr ->+ fill+ (core $ Exp (Memory.load paramPtr))+ finalPtr shapePtr bufferPtr)++ withManagedParam $ \param ->+ Marshal.alloca $ \shptr ->+ alloca $ \finalPtr ->+ Marshal.with param $ \paramPtr -> do+ fptr <- mallocArray =<< fsh paramPtr shptr+ withForeignPtr fptr $ farr paramPtr finalPtr shptr+ sh <- Marshal.peek shptr+ final <- peek finalPtr+ return (final, Array sh fptr)+++foreign import ccall safe "dynamic" callShaper2 ::+ Importer+ (LLVM.Ptr param ->+ LLVM.Ptr shapeA -> LLVM.Ptr shapeB -> Ptr Shape.Size -> IO ())++foreign import ccall safe "dynamic" callFill2 ::+ Importer+ (LLVM.Ptr param ->+ LLVM.Ptr shapeA -> Ptr a -> LLVM.Ptr shapeB -> Ptr b -> IO ())+++materialize2 ::+ (Shape.C sha, Marshal.C sha,+ Shape.C shb, Marshal.C shb,+ Marshal.C p, Storable.C a, Storable.C b) =>+ String ->+ (core -> Exp (sha,shb)) ->+ (core ->+ (LLVM.Value (MarshalPtr sha), LLVM.Value (Ptr a)) ->+ (LLVM.Value (MarshalPtr shb), LLVM.Value (Ptr b)) ->+ LLVM.CodeGenFunction () ()) ->+ Parametric p core -> IO (Rendered p (Array sha a, Array shb b))+materialize2 name shape fill core = do+ (fsh, farr) <-+ Code.compile name $+ liftA2 (,)+ (Code.createFunction callShaper2 "shape" $+ \paramPtr shapeAPtr shapeBPtr sizesPtr -> do+ (sha,shb) <-+ fmap MultiValue.unzip $ unExp $+ shape $ core $ Exp (Memory.load paramPtr)+ Memory.store sha shapeAPtr+ Memory.store shb shapeBPtr+ sizeAPtr <- LLVM.bitcast sizesPtr+ flip LLVM.store sizeAPtr =<< Shape.size sha+ sizeBPtr <- A.advanceArrayElementPtr sizeAPtr+ flip LLVM.store sizeBPtr =<< Shape.size shb)+ (Code.createFunction callFill2 "fill" $+ \paramPtr shapeAPtr bufferAPtr shapeBPtr bufferBPtr ->+ fill+ (core $ Exp (Memory.load paramPtr))+ (shapeAPtr, bufferAPtr) (shapeBPtr, bufferBPtr))++ withManagedParam $ \param ->+ Marshal.alloca $ \shaPtr ->+ Marshal.alloca $ \shbPtr ->+ allocaArray 2 $ \sizesPtr ->+ Marshal.with param $ \paramPtr -> do+ fsh paramPtr shaPtr shbPtr sizesPtr+ afptr <- mallocArray =<< peekElemOff sizesPtr 0+ bfptr <- mallocArray =<< peekElemOff sizesPtr 1+ withForeignPtr afptr $ \aptr ->+ withForeignPtr bfptr $ \bptr ->+ farr paramPtr shaPtr aptr shbPtr bptr+ sha <- Marshal.peek shaPtr+ shb <- Marshal.peek shbPtr+ return (Array sha afptr, Array shb bfptr)+++render ::+ (Shape.C sh, Shape.Index sh ~ ix, Marshal.C sh,+ Marshal.C p, Storable.C a) =>+ Parametric p (Core.Array sh a) -> IO (Rendered p (Array sh a))+render =+ materialize "render" Core.shape+ (\(Core.Array esh code) shapePtr bufferPtr -> do+ let step ix p = flip Storable.storeNext p =<< code ix+ sh <- Shape.load esh shapePtr+ void $ Shape.loop step sh bufferPtr)+++data Scatter sh0 sh1 a =+ Scatter {+ scatterAccum :: Exp a -> Exp a -> Exp a,+ scatterInit :: Core.Array sh1 a,+ scatterMap :: Core.Array sh0 (Shape.Index sh1, a)+ }++scatter ::+ (Shape.C sh0, Shape.Index sh0 ~ ix0,+ Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,+ Marshal.C p, Storable.C a) =>+ Parametric p (Scatter sh0 sh1 a) -> IO (Rendered p (Array sh1 a))+scatter =+ materialize "scatter"+ (Core.shape . scatterInit)+ (\(Scatter accum arrInit arrMap) ->+ Priv.scatter accum arrInit arrMap)++++data ScatterMaybe sh0 sh1 a =+ ScatterMaybe {+ scatterMaybeAccum :: Exp a -> Exp a -> Exp a,+ scatterMaybeInit :: Core.Array sh1 a,+ scatterMaybeMap :: Core.Array sh0 (Maybe (Shape.Index sh1, a))+ }++scatterMaybe ::+ (Shape.C sh0, Shape.Index sh0 ~ ix0,+ Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,+ Marshal.C p, Storable.C a) =>+ Parametric p (ScatterMaybe sh0 sh1 a) -> IO (Rendered p (Array sh1 a))+scatterMaybe =+ materialize "scatterMaybe"+ (Core.shape . scatterMaybeInit)+ (\(ScatterMaybe accum arrInit arrMap) ->+ Priv.scatterMaybe accum arrInit arrMap)+++data MapAccumLSimple sh n acc a b =+ MapAccumLSimple {+ mapAccumLSimpleAccum :: Exp acc -> Exp a -> Exp (acc,b),+ mapAccumLSimpleInit :: Core.Array sh acc,+ mapAccumLSimpleArray :: Core.Array (sh, n) a+ }++mapAccumLSimple ::+ (Shape.C sh, Marshal.C sh,+ Shape.C n, Marshal.C n,+ MultiValue.C acc, Marshal.C p, Storable.C a, Storable.C b) =>+ Parametric p (MapAccumLSimple sh n acc a b) ->+ IO (Rendered p (Array (sh,n) b))+mapAccumLSimple =+ materialize "mapAccumLSimple"+ (Core.shape . mapAccumLSimpleArray)+ (\(MapAccumLSimple f arrInit arrData) ->+ Priv.mapAccumLSimple f arrInit arrData)+++data MapAccumLSequence n acc final a b =+ MapAccumLSequence {+ mapAccumLSequenceAccum :: Exp acc -> Exp a -> Exp (acc,b),+ mapAccumLSequenceFinal :: Exp acc -> Exp final,+ mapAccumLSequenceInit :: Exp acc,+ mapAccumLSequenceArray :: Core.Array n a+ }++-- FIXME: check correct size of array of initial values+mapAccumLSequence ::+ (Shape.C n, Marshal.C n, MultiValue.C acc, Storable.C final,+ Marshal.C p, Storable.C a, Storable.C b) =>+ Parametric p (MapAccumLSequence n acc final a b) ->+ IO (Rendered p (final, Array n b))+mapAccumLSequence =+ materializeExpArray "mapAccumLSequence"+ (Core.shape . mapAccumLSequenceArray)+ (\(MapAccumLSequence f final expInit arr) ->+ Priv.mapAccumLSequence f final expInit arr)+++data MapAccumL sh n acc final a b =+ MapAccumL {+ mapAccumLAccum :: Exp acc -> Exp a -> Exp (acc,b),+ mapAccumLFinal :: Exp acc -> Exp final,+ mapAccumLInit :: Core.Array sh acc,+ mapAccumLArray :: Core.Array (sh, n) a+ }++-- FIXME: check correct size of array of initial values+mapAccumL ::+ (Shape.C sh, Marshal.C sh,+ Shape.C n, Marshal.C n,+ MultiValue.C acc, Storable.C final,+ Marshal.C p, Storable.C a, Storable.C b) =>+ Parametric p (MapAccumL sh n acc final a b) ->+ IO (Rendered p (Array sh final, Array (sh,n) b))+mapAccumL =+ materialize2 "mapAccumL"+ (\core ->+ Expr.zip+ (Core.shape $ mapAccumLInit core)+ (Core.shape $ mapAccumLArray core))+ (\(MapAccumL f final arrInit arrData) ->+ Priv.mapAccumL f final arrInit arrData)+++data FoldOuterL n sh a b =+ FoldOuterL {+ foldOuterLAccum :: Exp a -> Exp b -> Exp a,+ foldOuterLInit :: Core.Array sh a,+ foldOuterLArray :: Core.Array (n,sh) b+ }++-- FIXME: check correct size of array of initial values+foldOuterL ::+ (Shape.C n, Marshal.C n,+ Shape.C sh, Marshal.C sh,+ Marshal.C p, Storable.C a) =>+ Parametric p (FoldOuterL n sh a b) -> IO (Rendered p (Array sh a))+foldOuterL =+ materialize "foldOuterL"+ (Core.shape . foldOuterLInit)+ (\(FoldOuterL f arrInit arrData) -> Priv.foldOuterL f arrInit arrData)+++data MapFilter n a b =+ MapFilter {+ mapFilterMap :: Exp a -> Exp b,+ mapFilterPredicate :: Exp a -> Exp Bool,+ mapFilterArray :: Core.Array n a+ }++mapFilter ::+ (Shape.Sequence n, Marshal.C n, Marshal.C p, Storable.C b) =>+ Parametric p (MapFilter n a b) -> IO (Rendered p (Array n b))+mapFilter =+ materialize "mapFilter"+ (Core.shape . mapFilterArray)+ (\(MapFilter f p arr) shapePtr bufferPtr ->+ flip Memory.store shapePtr+ =<< Priv.mapFilter f p arr shapePtr bufferPtr)+++data FilterOuter n sh a =+ FilterOuter {+ filterOuterPredicate :: Core.Array n Bool,+ filterOuterArray :: Core.Array (n,sh) a+ }++-- FIXME: check correct size of row selection array+filterOuter ::+ (Shape.Sequence n, Marshal.C n,+ Shape.C sh, Marshal.C sh,+ Marshal.C p, Storable.C a) =>+ Parametric p (FilterOuter n sh a) -> IO (Rendered p (Array (n,sh) a))+filterOuter =+ materialize "filterOuter"+ (Core.shape . filterOuterArray)+ (\(FilterOuter p arr) shapePtr bufferPtr ->+ flip Memory.store shapePtr+ =<< Priv.filterOuter p arr shapePtr bufferPtr)+++data AddDimension sh n a b =+ AddDimension {+ addDimensionSize :: Exp n,+ addDimensionSelect :: Exp (Shape.Index n) -> Exp a -> Exp b,+ addDimensionArray :: Core.Array sh a+ }++addDimension ::+ (Shape.C sh, Marshal.C sh,+ Shape.C n, Marshal.C n,+ Marshal.C p, Storable.C b) =>+ Parametric p (AddDimension sh n a b) -> IO (Rendered p (Array (sh,n) b))+addDimension =+ materialize "addDimension"+ (\r -> Expr.zip (Core.shape (addDimensionArray r)) (addDimensionSize r))+ (\(AddDimension n select arr) -> Priv.addDimension n select arr)
src/Data/Array/Knead/Symbolic/Render.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} {- |-Simplify running the @render@ function by handling passing of parameters.+Apply operations on symbolic arrays to physical ones. -} module Data.Array.Knead.Symbolic.Render ( run,@@ -16,29 +16,24 @@ AddDimension(..), ) where -import qualified Data.Array.Knead.Parameterized.PhysicalHull as PhysHullP-import qualified Data.Array.Knead.Parameterized.Physical as PhysP-import qualified Data.Array.Knead.Parameterized.Private as Sym+import qualified Data.Array.Knead.Symbolic.Render.Basic as Render+import qualified Data.Array.Knead.Symbolic.Render.Argument as Arg+import qualified Data.Array.Knead.Symbolic.PhysicalParametric as PhysP import qualified Data.Array.Knead.Symbolic.Physical as Phys import qualified Data.Array.Knead.Symbolic.Private as Core import qualified Data.Array.Knead.Shape as Shape-import Data.Array.Knead.Parameterized.PhysicalHull+import Data.Array.Knead.Symbolic.PhysicalParametric (MapFilter, FilterOuter, MapAccumLSimple, MapAccumLSequence, MapAccumL, FoldOuterL, Scatter, ScatterMaybe, AddDimension)-import Data.Array.Knead.Expression (Exp, ) -import qualified LLVM.DSL.Parameter as Param+import qualified LLVM.DSL.Render.Run as Run+import LLVM.DSL.Expression (Exp) 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 Control.Arrow (arr, )-import Control.Applicative (liftA2, liftA3, pure, (<*>), )--import Data.Tuple.HT (fst3, snd3, thd3, )- import Prelude2010 import Prelude () @@ -46,20 +41,20 @@ class C f where type Plain f- build :: Sym.Hull p f -> IO (p -> Plain f)+ build :: (Marshal.C p) => Run.T IO p f (Plain f) instance (Marshal.C sh, Shape.C sh, Storable.C a) => C (Core.Array sh a) where type Plain (Core.Array sh a) = IO (Phys.Array sh a)- build = PhysHullP.render+ build = Run.Cons PhysP.render instance (Shape.Sequence n, Marshal.C n, Storable.C b, MultiValue.C b) => C (MapFilter n a b) where type Plain (MapFilter n a b) = IO (Phys.Array n b)- build = PhysHullP.mapFilter+ build = Run.Cons PhysP.mapFilter instance (Shape.Sequence n, Marshal.C n,@@ -67,7 +62,7 @@ Storable.C a, MultiValue.C a) => C (FilterOuter n sh a) where type Plain (FilterOuter n sh a) = IO (Phys.Array (n,sh) a)- build = PhysHullP.filterOuter+ build = Run.Cons PhysP.filterOuter instance (Shape.C sh0, Marshal.C sh0,@@ -75,7 +70,7 @@ Storable.C a, MultiValue.C a) => C (Scatter sh0 sh1 a) where type Plain (Scatter sh0 sh1 a) = IO (Phys.Array sh1 a)- build = PhysHullP.scatter+ build = Run.Cons PhysP.scatter instance (Shape.C sh0, Marshal.C sh0,@@ -83,7 +78,7 @@ Storable.C a, MultiValue.C a) => C (ScatterMaybe sh0 sh1 a) where type Plain (ScatterMaybe sh0 sh1 a) = IO (Phys.Array sh1 a)- build = PhysHullP.scatterMaybe+ build = Run.Cons PhysP.scatterMaybe instance (Shape.C sh, Marshal.C sh,@@ -93,7 +88,7 @@ Storable.C b, MultiValue.C b) => C (MapAccumLSimple sh n acc a b) where type Plain (MapAccumLSimple sh n acc a b) = IO (Phys.Array (sh,n) b)- build = PhysHullP.mapAccumLSimple+ build = Run.Cons PhysP.mapAccumLSimple instance (Shape.C n, Marshal.C n,@@ -103,7 +98,7 @@ Storable.C b, MultiValue.C b) => C (MapAccumLSequence n acc final a b) where type Plain (MapAccumLSequence n acc final a b) = IO (final, Phys.Array n b)- build = PhysHullP.mapAccumLSequence+ build = Run.Cons PhysP.mapAccumLSequence instance (Shape.C sh, Marshal.C sh,@@ -115,7 +110,7 @@ C (MapAccumL sh n acc final a b) where type Plain (MapAccumL sh n acc final a b) = IO (Phys.Array sh final, Phys.Array (sh,n) b)- build = PhysHullP.mapAccumL+ build = Run.Cons PhysP.mapAccumL instance (Shape.C n, Marshal.C n,@@ -124,7 +119,7 @@ Storable.C b, MultiValue.C b) => C (FoldOuterL n sh a b) where type Plain (FoldOuterL n sh a b) = IO (Phys.Array sh a)- build = PhysHullP.foldOuterL+ build = Run.Cons PhysP.foldOuterL instance (Shape.C sh, Marshal.C sh,@@ -132,69 +127,51 @@ Storable.C b, MultiValue.C b) => C (AddDimension sh n a b) where type Plain (AddDimension sh n a b) = IO (Phys.Array (sh,n) b)- build = PhysHullP.addDimension+ build = Run.Cons PhysP.addDimension -singleton :: Exp a -> Core.Array () a-singleton = Core.fromScalar- instance (Storable.C a, MultiValue.C a) => C (Exp a) where type Plain (Exp a) = IO a- build = PhysP.the . Sym.runHull . fmap singleton+ build = Render.storable newtype MarshalExp a = MarshalExp {getMarshalExp :: Exp a} instance (Marshal.C a) => C (MarshalExp a) where type Plain (MarshalExp a) = IO a- build = PhysP.theMarshal . Sym.runHull . fmap (singleton . getMarshalExp)+ build = Run.premapDSL getMarshalExp Render.marshal instance (Argument arg, C func) => C (arg -> func) where type Plain (arg -> func) = PlainArg arg -> Plain func- build f = fmap curry $ build $ Sym.extendHull fst f <*> buildArg (arr snd)+ build = buildArg Render.*-> build -class Argument arg where- type PlainArg arg- buildArg :: Param.T p (PlainArg arg) -> Sym.Hull p arg+class Argument a where+ type PlainArg a+ buildArg :: Arg.T (PlainArg a) a +instance Argument () where+ type PlainArg () = ()+ buildArg = Arg.unit+ instance (Shape.C sh, Marshal.C sh, Storable.C a) => Argument (Core.Array sh a) where type PlainArg (Core.Array sh a) = Phys.Array sh a- buildArg = Sym.arrayHull . PhysP.feed+ buildArg = Arg.array instance (Marshal.C a) => Argument (Exp a) where type PlainArg (Exp a) = a- buildArg = Sym.expHull . Sym.expParam+ buildArg = Arg.primitive instance (Argument a, Argument b) => Argument (a,b) where type PlainArg (a,b) = (PlainArg a, PlainArg b)- buildArg p = liftA2 (,) (buildArg $ fmap fst p) (buildArg $ fmap snd p)+ buildArg = Arg.pair buildArg buildArg instance (Argument a, Argument b, Argument c) => Argument (a,b,c) where type PlainArg (a,b,c) = (PlainArg a, PlainArg b, PlainArg c)- buildArg p =- liftA3 (,,)- (buildArg $ fmap fst3 p) (buildArg $ fmap snd3 p) (buildArg $ fmap thd3 p)---run :: (C f) => f -> IO (Plain f)-run f = fmap ($ ()) $ build $ pure f+ buildArg = Arg.triple buildArg buildArg buildArg -_example ::- (Marshal.C x,- Shape.C sha, Marshal.C sha, Storable.C a,- Shape.C shb, Marshal.C shb, Storable.C b,- Shape.C shc, Marshal.C shc, Storable.C c) =>- (Exp x -> Core.Array sha a -> Core.Array shb b -> Core.Array shc c) ->- IO (x -> Phys.Array sha a -> Phys.Array shb b -> IO (Phys.Array shc c))-_example f =- fmap (\g -> curry $ curry g) $- PhysP.render $- Sym.runHull $- pure f- <*> Sym.expHull (Sym.expParam $ arr (fst.fst))- <*> Sym.arrayHull (PhysP.feed $ arr (snd.fst))- <*> Sym.arrayHull (PhysP.feed $ arr snd)+run :: (C f) => f -> IO (Plain f)+run = Render.run build
+ src/Data/Array/Knead/Symbolic/Render/Argument.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+module Data.Array.Knead.Symbolic.Render.Argument (+ Arg.T(Arg.Cons),+ Arg.unit,+ Arg.primitive,+ Arg.pair,+ Arg.triple,+ array,+ ) where++import qualified Data.Array.Knead.Symbolic.Physical as Phys+import qualified Data.Array.Knead.Symbolic.Private as Core+import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Code (getElementPtr)++import qualified Data.Array.Comfort.Storable.Unchecked as Array++import qualified LLVM.DSL.Render.Argument as Arg+import LLVM.DSL.Expression (unExp)++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 Foreign.ForeignPtr (withForeignPtr, touchForeignPtr)++import Prelude2010+import Prelude ()++++array ::+ (Shape.C sh, Marshal.C sh, Storable.C a) =>+ Arg.T (Phys.Array sh a) (Core.Array sh a)+array =+ Arg.Cons+ (Expr.uncurry $ \esh eptr ->+ Core.Array esh+ (\ix -> do+ sh <- unExp esh+ MultiValue.Cons ptr <- unExp eptr+ Storable.load =<< getElementPtr sh ptr ix))+ (\(Array.Array sh fptr) ->+ withForeignPtr fptr $ \ptr ->+ return ((sh, ptr), touchForeignPtr fptr))
+ src/Data/Array/Knead/Symbolic/Render/Basic.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+{- |+Apply operations on symbolic arrays to physical ones.++This is an approach with no pre-defined direction of type dependencies.+-}+module Data.Array.Knead.Symbolic.Render.Basic (+ run,+ (*->),++ storable,+ marshal,+ array,+ scatter,+ ) where++import qualified Data.Array.Knead.Symbolic.Render.Argument as Arg+import qualified Data.Array.Knead.Symbolic.PhysicalParametric as PhysP+import qualified Data.Array.Knead.Symbolic.Physical as Phys+import qualified Data.Array.Knead.Symbolic.Private as Core+import qualified Data.Array.Knead.Shape as Shape++import qualified Data.Array.Comfort.Storable.Unchecked as Array++import qualified LLVM.DSL.Render.Run as Run+import LLVM.DSL.Render.Run (run, (*->))+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal++import Prelude2010+import Prelude ()++++_example1raw ::+ (Marshal.C sh, Shape.C sh, Marshal.C z, Marshal.C a, Storable.C b) =>+ Run.T IO z (Exp a -> Core.Array sh b) (a -> IO (Phys.Array sh b))+_example1raw = Arg.primitive *-> array++_example2raw ::+ (Marshal.C sh, Shape.C sh,+ Marshal.C z, Marshal.C a, Marshal.C b, Storable.C c) =>+ Run.T IO z+ (Exp a -> Exp b -> Core.Array sh c)+ (a -> b -> IO (Phys.Array sh c))+_example2raw = Arg.primitive *-> Arg.primitive *-> array+++_example2 ::+ (Marshal.C sh, Shape.C sh,+ Marshal.C a, Marshal.C b, Storable.C c) =>+ (Exp a -> Exp b -> Core.Array sh c) ->+ IO (a -> b -> IO (Phys.Array sh c))+_example2 = run (Arg.primitive *-> Arg.primitive *-> array)++_example2exp ::+ (Marshal.C a, Marshal.C b, Storable.C c) =>+ (Exp a -> Exp b -> Exp c) ->+ IO (a -> b -> IO c)+_example2exp = run (Arg.primitive *-> Arg.primitive *-> storable)++_example2marshal ::+ (Marshal.C a, Marshal.C b, Marshal.C c) =>+ (Exp a -> Exp b -> Exp c) ->+ IO (a -> b -> IO c)+_example2marshal = run (Arg.primitive *-> Arg.primitive *-> marshal)++_example2scatter ::+ (Shape.C sh0, Shape.C sh1, Marshal.C sh1,+ Marshal.C a, Marshal.C b, Storable.C c) =>+ (Exp a -> Exp b -> PhysP.Scatter sh0 sh1 c) ->+ IO (a -> b -> IO (Array.Array sh1 c))+_example2scatter = run (Arg.primitive *-> Arg.primitive *-> scatter)+++++singleton :: Exp a -> Core.Array () a+singleton = Core.fromScalar++storable :: (Marshal.C p, Storable.C a) => Run.T IO p (Exp a) (IO a)+storable = Run.Cons $ PhysP.the . fmap singleton++marshal :: (Marshal.C p, Marshal.C a) => Run.T IO p (Exp a) (IO a)+marshal = Run.Cons $ PhysP.theMarshal . fmap singleton++array ::+ (Shape.C sh, Shape.Index sh ~ ix, Marshal.C sh,+ Marshal.C p, Storable.C a) =>+ Run.T IO p (Core.Array sh a) (IO (Phys.Array sh a))+array = Run.Cons PhysP.render+++scatter ::+ (Shape.C sh0, Shape.C sh1, Marshal.C sh1, Marshal.C p, Storable.C a) =>+ Run.T IO p (PhysP.Scatter sh0 sh1 a) (IO (Array.Array sh1 a))+scatter = Run.Cons PhysP.scatter
+ src/Data/Array/Knead/Symbolic/RenderAlt.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE TypeFamilies #-}+{- |+Apply operations on symbolic arrays to physical ones.++In contrast to the "Data.Array.Knead.Symbolic.Render" module,+here we map from Haskell types to LLVM ones.+This is analogous to "Synthesizer.LLVM.Generator.Render".+-}+module Data.Array.Knead.Symbolic.RenderAlt (+ run,+ MarshalValue(..),+ ) where++import qualified Data.Array.Knead.Symbolic.Render.Basic as Render+import qualified Data.Array.Knead.Symbolic.Render.Argument as Arg+import qualified Data.Array.Knead.Symbolic.PhysicalParametric as PhysP+import qualified Data.Array.Knead.Symbolic.Physical as Phys+import qualified Data.Array.Knead.Symbolic.Private as Core+import qualified Data.Array.Knead.Shape as Shape++import qualified LLVM.DSL.Render.Run as Run+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Multi.Value.Storable as Storable+import qualified LLVM.Extra.Multi.Value.Marshal as Marshal++import Data.Word (Word, Word32)++import Prelude2010+import Prelude ()++++class C f where+ type DSL f+ build :: (Marshal.C p) => Run.T IO p (DSL f) f++instance (C_IO a) => C (IO a) where+ type DSL (IO a) = DSL_IO a+ build = buildIO+++class C_IO f where+ type DSL_IO f+ buildIO :: (Marshal.C p) => Run.T IO p (DSL_IO f) (IO f)++instance+ (Marshal.C sh, Shape.C sh, Storable.C a) =>+ C_IO (Phys.Array sh a) where+ type DSL_IO (Phys.Array sh a) = Core.Array sh a+ buildIO = Run.Cons PhysP.render+++instance C_IO Float where+ type DSL_IO Float = Exp Float+ buildIO = Render.storable++instance C_IO Word32 where+ type DSL_IO Word32 = Exp Word32+ buildIO = Render.storable++newtype MarshalValue a = MarshalValue {getMarshalValue :: a}++instance (Marshal.C a) => C_IO (MarshalValue a) where+ type DSL_IO (MarshalValue a) = Exp a+ buildIO = Run.postmapPlain (fmap MarshalValue) Render.marshal+++instance (Argument arg, C func) => C (arg -> func) where+ type DSL (arg -> func) = DSLArg arg -> DSL func+ build = buildArg Render.*-> build++++class Argument a where+ type DSLArg a+ buildArg :: Arg.T a (DSLArg a)++instance Argument () where+ type DSLArg () = ()+ buildArg = Arg.unit++instance+ (Shape.C sh, Marshal.C sh, Storable.C a) =>+ Argument (Phys.Array sh a) where+ type DSLArg (Phys.Array sh a) = Core.Array sh a+ buildArg = Arg.array+++instance Argument Float where+ type DSLArg Float = Exp Float+ buildArg = Arg.primitive++instance Argument Int where+ type DSLArg Int = Exp Int+ buildArg = Arg.primitive++instance Argument Word where+ type DSLArg Word = Exp Word+ buildArg = Arg.primitive++instance Argument Word32 where+ type DSLArg Word32 = Exp Word32+ buildArg = Arg.primitive++instance (Argument a, Argument b) => Argument (a,b) where+ type DSLArg (a,b) = (DSLArg a, DSLArg b)+ buildArg = Arg.pair buildArg buildArg++instance (Argument a, Argument b, Argument c) => Argument (a,b,c) where+ type DSLArg (a,b,c) = (DSLArg a, DSLArg b, DSLArg c)+ buildArg = Arg.triple buildArg buildArg buildArg++++run :: (C f) => DSL f -> IO f+run = Render.run build