packages feed

knead 0.5 → 1.0

raw patch · 30 files changed

+1537/−1585 lines, 30 filesdep ~comfort-arraydep ~llvm-dsldep ~llvm-extra

Dependency ranges changed: comfort-array, llvm-dsl, llvm-extra, llvm-tf, transformers

Files

knead.cabal view
@@ -1,10 +1,10 @@ Name:             knead-Version:          0.5+Version:          1.0 License:          BSD3 License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de> Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>-Homepage:         http://hub.darcs.net/thielema/knead/+Homepage:         https://hub.darcs.net/thielema/knead/ Category:         Data Structures Synopsis:         Repa-like array processing using LLVM JIT Description:@@ -43,39 +43,40 @@   .   The name of the package is inspired by the visualization of typical operations   like reshaping, collapsing a dimension and extruding another one.-Tested-With:      GHC==7.4.2, GHC==7.8.4-Tested-With:      GHC==8.4.3, GHC==8.6.1-Cabal-Version:    >=1.8+Tested-With:      GHC==8.4.4, GHC==8.6.5, GHC==8.10.7+Tested-With:      GHC==9.0.2, GHC==9.2.8, GHC==9.4.6+Cabal-Version:    >=1.10 Build-Type:       Simple Extra-Source-Files:   Makefile  Source-Repository this-  Tag:         0.5+  Tag:         1.0   Type:        darcs-  Location:    http://hub.darcs.net/thielema/knead/+  Location:    https://hub.darcs.net/thielema/knead/  Source-Repository head   Type:        darcs-  Location:    http://hub.darcs.net/thielema/knead/+  Location:    https://hub.darcs.net/thielema/knead/  Library   Build-Depends:-    llvm-dsl >=0.0 && <0.1,-    llvm-extra >=0.10 && <0.11,-    llvm-tf >=9.2 && <9.3,+    llvm-dsl >=0.1 && <0.2,+    llvm-extra >=0.11 && <0.12,+    llvm-tf >=9.2 && <13.0,     tfp >=1.0 && <1.1,-    comfort-array >=0.3 && <0.5,+    comfort-array >=0.5 && <0.6,     fixed-length >=0.2.1 && <0.3,     storable-record >=0.0.5 && <0.1,     storable-enum >=0.0 && <0.1,     bool8 >=0.0 && <0.1,-    transformers >=0.3 && <0.6,+    transformers >=0.3 && <0.7,     tagged >=0.7 && <0.9,     utility-ht >=0.0.15 && <0.1,     prelude-compat >=0.0 && <0.0.1,     base >=4 && <5 +  Default-Language: Haskell98   GHC-Options:      -Wall   Hs-Source-Dirs:   src   Exposed-Modules:@@ -83,22 +84,21 @@     Data.Array.Knead.Shape.Cubic     Data.Array.Knead.Shape.Cubic.Int     Data.Array.Knead.Expression-    Data.Array.Knead.Expression.Vector-    Data.Array.Knead.Parameter-    Data.Array.Knead.Simple.Symbolic-    Data.Array.Knead.Simple.ShapeDependent-    Data.Array.Knead.Simple.Physical-    Data.Array.Knead.Simple.Slice-    Data.Array.Knead.Simple.Fold-    Data.Array.Knead.Parameterized.Symbolic-    Data.Array.Knead.Parameterized.Physical-    Data.Array.Knead.Parameterized.Slice-    Data.Array.Knead.Parameterized.Render+    Data.Array.Knead.Symbolic+    Data.Array.Knead.Symbolic.ShapeDependent+    Data.Array.Knead.Symbolic.Physical+    Data.Array.Knead.Symbolic.Slice+    Data.Array.Knead.Symbolic.Fold+    Data.Array.Knead.Symbolic.Render   Other-Modules:-    Data.Array.Knead.Simple.Private-    Data.Array.Knead.Simple.PhysicalPrivate+    Data.Array.Knead.Parameter+    Data.Array.Knead.Symbolic.Private+    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 @@ -113,6 +113,7 @@     tfp,     utility-ht,     base+  Default-Language: Haskell98   GHC-Options: -Wall   Hs-Source-Dirs: test   Main-Is: Main.hs
src/Data/Array/Knead/Code.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Code where  import qualified Data.Array.Knead.Shape as Shape +import qualified LLVM.Extra.Multi.Value.Storable as Storable import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Storable as Storable  import qualified LLVM.Core as LLVM
src/Data/Array/Knead/Expression.hs view
@@ -12,9 +12,9 @@    unliftM1,    unliftM2,    unliftM3,-   liftTupleM,-   liftTupleM2,-   liftTupleM3,+   liftReprM,+   liftReprM2,+   liftReprM3,    zip,    zip3,    zip4,
− src/Data/Array/Knead/Expression/Vector.hs 
@@ -1,110 +0,0 @@-module Data.Array.Knead.Expression.Vector where--import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp)--import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec-import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Multi.Vector as MultiVector-import qualified LLVM.Core as LLVM--import Prelude hiding (replicate, zip, fst, snd)---cons ::-   (LLVM.Positive n, MultiVector.C a) =>-   LLVM.Vector n a -> Exp (LLVM.Vector n a)-cons = Expr.lift0 . MultiValueVec.cons--fst ::-   (LLVM.Positive n, MultiVector.C a, MultiVector.C b) =>-   Exp (LLVM.Vector n (a,b)) -> Exp (LLVM.Vector n a)-fst = Expr.lift1 MultiValueVec.fst--snd ::-   (LLVM.Positive n, MultiVector.C a, MultiVector.C b) =>-   Exp (LLVM.Vector n (a,b)) -> Exp (LLVM.Vector n b)-snd = Expr.lift1 MultiValueVec.snd--swap ::-   (LLVM.Positive n, MultiVector.C a, MultiVector.C b) =>-   Exp (LLVM.Vector n (a,b)) -> Exp (LLVM.Vector n (b,a))-swap = Expr.lift1 MultiValueVec.swap--mapFst ::-   (Exp (LLVM.Vector n a0) -> Exp (LLVM.Vector n a1)) ->-   Exp (LLVM.Vector n (a0,b)) -> Exp (LLVM.Vector n (a1,b))-mapFst f =-   Expr.liftM-      (MultiValue.liftM-         (\(a0,b) -> do-            MultiValue.Cons a1 <- Expr.unliftM1 f $ MultiValue.Cons a0-            return (a1,b)))--mapSnd ::-   (Exp (LLVM.Vector n b0) -> Exp (LLVM.Vector n b1)) ->-   Exp (LLVM.Vector n (a,b0)) -> Exp (LLVM.Vector n (a,b1))-mapSnd f =-   Expr.liftM-      (MultiValue.liftM-         (\(a,b0) -> do-            MultiValue.Cons b1 <- Expr.unliftM1 f $ MultiValue.Cons b0-            return (a,b1)))---fst3 ::-   (LLVM.Positive n, MultiVector.C a, MultiVector.C b, MultiVector.C c) =>-   Exp (LLVM.Vector n (a,b,c)) -> Exp (LLVM.Vector n a)-fst3 = Expr.lift1 MultiValueVec.fst3--snd3 ::-   (LLVM.Positive n, MultiVector.C a, MultiVector.C b, MultiVector.C c) =>-   Exp (LLVM.Vector n (a,b,c)) -> Exp (LLVM.Vector n b)-snd3 = Expr.lift1 MultiValueVec.snd3--thd3 ::-   (LLVM.Positive n, MultiVector.C a, MultiVector.C b, MultiVector.C c) =>-   Exp (LLVM.Vector n (a,b,c)) -> Exp (LLVM.Vector n c)-thd3 = Expr.lift1 MultiValueVec.thd3---zip ::-   (LLVM.Positive n, MultiVector.C a, MultiVector.C b) =>-   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n b) ->-   Exp (LLVM.Vector n (a,b))-zip = Expr.lift2 MultiValueVec.zip--zip3 ::-   (LLVM.Positive n, MultiVector.C a, MultiVector.C b, MultiVector.C c) =>-   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n b) -> Exp (LLVM.Vector n c) ->-   Exp (LLVM.Vector n (a,b,c))-zip3 = Expr.lift3 MultiValueVec.zip3---replicate ::-   (LLVM.Positive n, MultiVector.C a) =>-   Exp a -> Exp (LLVM.Vector n a)-replicate = Expr.liftM MultiValueVec.replicate--take ::-   (LLVM.Positive n, LLVM.Positive m, MultiVector.Select a) =>-   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector m a)-take = Expr.liftM MultiValueVec.take--takeRev ::-   (LLVM.Positive n, LLVM.Positive m, MultiVector.Select a) =>-   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector m a)-takeRev = Expr.liftM MultiValueVec.takeRev---cmp ::-   (LLVM.Positive n, MultiVector.Comparison a) =>-   LLVM.CmpPredicate ->-   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n Bool)-cmp ord = Expr.liftM2 (MultiValueVec.cmp ord)--select ::-   (LLVM.Positive n, MultiVector.Select a) =>-   Exp (LLVM.Vector n Bool) ->-   Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n a) -> Exp (LLVM.Vector n a)-select = Expr.liftM3 MultiValueVec.select
src/Data/Array/Knead/Parameterized/Physical.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ForeignFunctionInterface #-} module Data.Array.Knead.Parameterized.Physical (    Phys.Array,@@ -18,8 +19,8 @@  import qualified Data.Array.Knead.Parameterized.PhysicalHull as PhysHull import qualified Data.Array.Knead.Parameterized.Private as Sym-import qualified Data.Array.Knead.Simple.Physical as Phys-import qualified Data.Array.Knead.Simple.Private as Core+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)@@ -30,9 +31,9 @@ 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.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory  import qualified LLVM.Core as LLVM@@ -50,7 +51,7 @@  {-# INLINE feed #-} feed ::-   (Shape.C sh, Marshal.MV sh, Storable.C a) =>+   (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 ->@@ -59,7 +60,7 @@          case mapFst valueShape $ MultiValue.unzip p of             (sh, MultiValue.Cons ptr) ->                Core.Array (Expr.lift0 sh) $-                  Storable.loadMultiValue <=< getElementPtr sh ptr)+                  Storable.load <=< getElementPtr sh ptr)       (\p ->          case Array.buffer $ Param.get arr p of             fptr ->@@ -86,8 +87,7 @@          case arr param of             Core.Array z code ->                code (Shape.zeroIndex z) >>=-               flip Storable.storeMultiValue resultPtr-         LLVM.ret ()+               flip Storable.store resultPtr    return $ \p ->       bracket (create p) (delete . fst) $ \(_ctx, param) ->       Marshal.with param $ \pptr ->@@ -97,7 +97,7 @@    Importer (LLVM.Ptr param -> LLVM.Ptr a -> IO ())  theMarshal ::-   (Shape.Scalar z, Marshal.C a, MultiValue.C a) =>+   (Shape.Scalar z, Marshal.C a) =>    Sym.Array p z a -> IO (p -> IO a) theMarshal (Sym.Array arr create delete) = do    func <-@@ -109,7 +109,6 @@             Core.Array z code ->                code (Shape.zeroIndex z) >>=                flip Memory.store resultPtr-         LLVM.ret ()    return $ \p ->       bracket (create p) (delete . fst) $ \(_ctx, param) ->       Marshal.with param $ \pptr ->@@ -123,7 +122,7 @@   renderShape ::-   (Shape.C sh, Marshal.MV sh,+   (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@@ -136,7 +135,7 @@            Core.Array esh _code -> do               sh <- unExp esh               Memory.store sh resultPtr-              Shape.size sh >>= LLVM.ret+              Shape.size sh    return $ \p ->       bracket (create p) (delete . fst) $ \(_ctx, param) ->       Marshal.alloca $ \shptr ->@@ -147,14 +146,14 @@   render ::-   (Shape.C sh, Marshal.MV sh, Storable.C a) =>+   (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.MV sh,-    Shape.C n, Marshal.MV n,+   (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) =>@@ -169,8 +168,8 @@          (Sym.arrayHull arrMap)  foldOuterL ::-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,+   (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 ->@@ -184,7 +183,7 @@  scatter ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    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 ->@@ -197,7 +196,7 @@  scatterMaybe ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    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 ->@@ -210,7 +209,7 @@  permute ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    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 ->
src/Data/Array/Knead/Parameterized/PhysicalHull.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ForeignFunctionInterface #-} module Data.Array.Knead.Parameterized.PhysicalHull (    render,@@ -23,20 +24,20 @@    ) where  import qualified Data.Array.Knead.Parameterized.Private as Sym-import qualified Data.Array.Knead.Simple.PhysicalPrivate as Priv-import qualified Data.Array.Knead.Simple.Private as Core+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.Simple.PhysicalPrivate (MarshalPtr)+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.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A @@ -73,7 +74,7 @@ An example is 'mapFilter'. -} materialize ::-   (Shape.C sh, Marshal.MV sh, Storable.C a) =>+   (Shape.C sh, Marshal.C sh, Storable.C a) =>    String ->    (core -> Exp sh) ->    (core ->@@ -89,12 +90,11 @@             param <- Memory.load paramPtr             sh <- unExp $ shape $ core param             Memory.store sh resultPtr-            Shape.size sh >>= LLVM.ret)+            Shape.size sh)          (Code.createFunction callFill "fill" $           \paramPtr shapePtr bufferPtr -> do             param <- Memory.load paramPtr-            fill (core param) shapePtr bufferPtr-            LLVM.ret ())+            fill (core param) shapePtr bufferPtr)     return $ \p ->       bracket (create p) (delete . fst) $ \(_ctx, param) ->@@ -111,7 +111,7 @@   materializeExpArray ::-   (Shape.C sh, Marshal.MV sh, Storable.C a, Storable.C b) =>+   (Shape.C sh, Marshal.C sh, Storable.C a, Storable.C b) =>    String ->    (core -> Exp sh) ->    (core ->@@ -129,12 +129,11 @@             param <- Memory.load paramPtr             sh <- unExp $ shape $ core param             Memory.store sh resultPtr-            Shape.size sh >>= LLVM.ret)+            Shape.size sh)          (Code.createFunction callFillExpArray "fill" $           \paramPtr finalPtr shapePtr bufferPtr -> do             param <- Memory.load paramPtr-            fill (core param) finalPtr shapePtr bufferPtr-            LLVM.ret ())+            fill (core param) finalPtr shapePtr bufferPtr)     return $ \p ->       bracket (create p) (delete . fst) $ \(_ctx, param) ->@@ -160,8 +159,8 @@   materialize2 ::-   (Shape.C sha, Marshal.MV sha,-    Shape.C shb, Marshal.MV shb,+   (Shape.C sha, Marshal.C sha,+    Shape.C shb, Marshal.C shb,     Storable.C a, Storable.C b) =>    String ->    (core -> Exp (sha,shb)) ->@@ -183,13 +182,11 @@             sizeAPtr <- LLVM.bitcast sizesPtr             flip LLVM.store sizeAPtr =<< Shape.size sha             sizeBPtr <- A.advanceArrayElementPtr sizeAPtr-            flip LLVM.store sizeBPtr =<< Shape.size shb-            LLVM.ret ())+            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)-            LLVM.ret ())+            fill (core param) (shapeAPtr, bufferAPtr) (shapeBPtr, bufferBPtr))     return $ \p ->       bracket (create p) (delete . fst) $ \(_ctx, param) ->@@ -209,13 +206,13 @@   render ::-   (Shape.C sh, Shape.Index sh ~ ix, Marshal.MV sh,+   (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.storeNextMultiValue p =<< code ix+         let step ix p = flip Storable.storeNext p =<< code ix          sh <- Shape.load esh shapePtr          void $ Shape.loop step sh bufferPtr) @@ -229,7 +226,7 @@  scatter ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    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 =@@ -249,7 +246,7 @@  scatterMaybe ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    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 =@@ -267,8 +264,8 @@    }  mapAccumLSimple ::-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,+   (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 =@@ -288,7 +285,7 @@  -- FIXME: check correct size of array of initial values mapAccumLSequence ::-   (Shape.C n, Marshal.MV n, MultiValue.C acc,+   (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) ->@@ -310,8 +307,8 @@  -- FIXME: check correct size of array of initial values mapAccumL ::-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,+   (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) =>@@ -336,8 +333,8 @@  -- FIXME: check correct size of array of initial values foldOuterL ::-   (Shape.C n, Marshal.MV n,-    Shape.C sh, Marshal.MV sh,+   (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 =@@ -354,7 +351,7 @@    }  mapFilter ::-   (Shape.Sequence n, Marshal.MV n, Storable.C b) =>+   (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"@@ -372,8 +369,8 @@  -- FIXME: check correct size of row selection array filterOuter ::-   (Shape.Sequence n, Marshal.MV n,-    Shape.C sh, Marshal.MV sh,+   (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 =@@ -392,8 +389,8 @@    }  addDimension ::-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,+   (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 =
src/Data/Array/Knead/Parameterized/Private.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Parameterized.Private where -import qualified Data.Array.Knead.Simple.Symbolic as Core+import qualified Data.Array.Knead.Symbolic as Core  import qualified Data.Array.Knead.Shape as Shape import qualified Data.Array.Knead.Expression as Expr@@ -10,8 +11,8 @@  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 LLVM.Extra.Marshal as Marshal  import Control.Monad (liftM2) import Control.Applicative (Applicative (pure, (<*>)), )@@ -26,7 +27,7 @@ -- in principle we could define Array in terms of Hull and Core.Array data Array p sh a =    forall parameter context.-   (Marshal.MV parameter) =>+   (Marshal.C parameter) =>    Array {       core :: MultiValue.T parameter -> Core.Array sh a,       createContext :: p -> IO (context, parameter),@@ -45,7 +46,7 @@   (!) ::-   (Shape.C sh, Shape.Index sh ~ ix, Marshal.MV ix,+   (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 =@@ -57,7 +58,7 @@   fill ::-   (Shape.C sh, Marshal.MV sh, Marshal.MV a) =>+   (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 ->@@ -78,7 +79,7 @@   id ::-   (Shape.C sh, Marshal.MV sh, Shape.Index sh ~ ix) =>+   (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 ->@@ -88,32 +89,32 @@       deletePlain  map ::-   (Shape.C sh, Marshal.MV c) =>+   (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.MV c, Shape.Index sh ~ ix) =>+   (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.MV c, MultiValue.C a) =>+   (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.MV c, MultiValue.C a) =>+   (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.MV c) =>+   (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@@ -127,7 +128,7 @@  data Hull p a =    forall parameter context.-   (Marshal.MV parameter) =>+   (Marshal.C parameter) =>    Hull {       hullCore :: MultiValue.T parameter -> a,       hullCreateContext :: p -> IO (context, parameter),@@ -182,7 +183,7 @@   -expParam :: (Marshal.MV a) => Param.T p a -> Param.Tunnel p a+expParam :: (Marshal.C a) => Param.T p a -> Param.Tunnel p a expParam = Param.tunnel MultiValue.cons
− src/Data/Array/Knead/Parameterized/Render.hs 
@@ -1,200 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{- |-Simplify running the @render@ function by handling passing of parameters.--}-module Data.Array.Knead.Parameterized.Render (-   run,-   MarshalExp(..),-   MapFilter(..),-   FilterOuter(..),-   Scatter(..),-   ScatterMaybe(..),-   MapAccumLSimple(..),-   MapAccumLSequence(..),-   MapAccumL(..),-   FoldOuterL(..),-   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.Simple.Physical as Phys-import qualified Data.Array.Knead.Simple.Private as Core-import qualified Data.Array.Knead.Shape as Shape-import Data.Array.Knead.Parameterized.PhysicalHull-         (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.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal--import Control.Arrow (arr, )-import Control.Applicative (liftA2, liftA3, pure, (<*>), )--import Data.Tuple.HT (fst3, snd3, thd3, )--import Prelude2010-import Prelude ()----class C f where-   type Plain f-   build :: Sym.Hull p f -> IO (p -> Plain f)--instance-   (Marshal.MV 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--instance-   (Shape.Sequence n, Marshal.MV 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--instance-   (Shape.Sequence n, Marshal.MV n,-    Shape.C sh, Marshal.MV sh,-    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--instance-   (Shape.C sh0, Marshal.MV sh0,-    Shape.C sh1, Marshal.MV sh1,-    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--instance-   (Shape.C sh0, Marshal.MV sh0,-    Shape.C sh1, Marshal.MV sh1,-    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--instance-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,-    MultiValue.C acc,-    Storable.C a, MultiValue.C a,-    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--instance-   (Shape.C n, Marshal.MV n,-    MultiValue.C acc,-    Storable.C final, MultiValue.C final,-    Storable.C a, MultiValue.C a,-    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--instance-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,-    MultiValue.C acc,-    Storable.C final, MultiValue.C final,-    Storable.C a, MultiValue.C a,-    Storable.C b, MultiValue.C b) =>-      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--instance-   (Shape.C n, Marshal.MV n,-    Shape.C sh, Marshal.MV sh,-    Storable.C a, MultiValue.C a,-    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--instance-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,-    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---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--newtype MarshalExp a = MarshalExp {getMarshalExp :: Exp a}--instance (Marshal.C a, MultiValue.C a) => C (MarshalExp a) where-   type Plain (MarshalExp a) = IO a-   build = PhysP.theMarshal . Sym.runHull . fmap (singleton . getMarshalExp)--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)---class Argument arg where-   type PlainArg arg-   buildArg :: Param.T p (PlainArg arg) -> Sym.Hull p arg--instance-   (Shape.C sh, Marshal.MV 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--instance (Marshal.MV a) => Argument (Exp a) where-   type PlainArg (Exp a) = a-   buildArg = Sym.expHull . Sym.expParam--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)--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----_example ::-   (Marshal.MV x,-    Shape.C sha, Marshal.MV sha, Storable.C a,-    Shape.C shb, Marshal.MV shb, Storable.C b,-    Shape.C shc, Marshal.MV 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)
src/Data/Array/Knead/Parameterized/Slice.hs view
@@ -14,8 +14,8 @@ import qualified Data.Array.Knead.Parameterized.Private as Priv import Data.Array.Knead.Parameterized.Private (Array(Array), ) -import qualified Data.Array.Knead.Simple.Slice as Slice-import qualified Data.Array.Knead.Simple.Private as Core+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@@ -25,8 +25,8 @@  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 LLVM.Extra.Marshal as Marshal  import qualified Type.Data.Num.Unary as Unary @@ -37,7 +37,7 @@ -} data T p sh0 sh1 =    forall parameter context.-   (Marshal.MV parameter) =>+   (Marshal.C parameter) =>    Cons {       _core :: MultiValue.T parameter -> Slice.T sh0 sh1,       _createContext :: p -> IO (context, parameter),@@ -85,7 +85,7 @@ extrude = lift Slice.extrude  lift ::-   (Marshal.MV i) =>+   (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
src/Data/Array/Knead/Parameterized/Symbolic.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Parameterized.Symbolic (    Array,    Exp,@@ -19,7 +20,7 @@    ) where  import qualified Data.Array.Knead.Parameterized.Private as Sym-import qualified Data.Array.Knead.Simple.Symbolic as Core+import qualified Data.Array.Knead.Symbolic as Core import Data.Array.Knead.Parameterized.Private (Array, gather, )  import qualified Data.Array.Knead.Shape as Shape@@ -28,8 +29,8 @@  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 LLVM.Extra.Marshal as Marshal  import Control.Applicative ((<*>), ) @@ -46,7 +47,7 @@  backpermute ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,     MultiValue.C a) =>    Param.T p sh1 ->    (Exp ix1 -> Exp ix0) ->@@ -56,7 +57,7 @@   zipWith ::-   (Shape.C sh, Marshal.MV d) =>+   (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 =@@ -64,14 +65,14 @@   withExp ::-   (Marshal.MV x) =>+   (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.MV x) =>+   (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 =@@ -80,7 +81,7 @@      <*> Sym.arrayHull b  withExp3 ::-   (Marshal.MV x) =>+   (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 ->
src/Data/Array/Knead/Shape.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}@@ -15,6 +16,8 @@     Range(Range), range, rangeFrom, rangeTo,    Shifted(Shifted), shifted, shiftedOffset, shiftedSize,+   Cyclic(Cyclic), cyclic, cyclicSize,+    Enumeration(Enumeration), EnumBounded(..),     Scalar(..),@@ -23,22 +26,22 @@  import qualified Data.Array.Knead.Expression as Expr import Data.Array.Knead.Shape.Orphan-         (zeroBased, zeroBasedSize,+         (zeroBased, zeroBasedSize, cyclic, cyclicSize,           singletonRange, unzipRange, singletonShifted, unzipShifted) import Data.Array.Knead.Expression (Exp, )  import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Shape-         (Index, ZeroBased, Range(Range), Shifted(Shifted),+         (Index, ZeroBased, Range(Range), Shifted(Shifted), Cyclic,           Enumeration(Enumeration)) import Data.Ix (Ix)  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 LLVM.Extra.Multi.Iterator as IterMV import qualified LLVM.Extra.Tuple as Tuple-import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Iterator as Iter import qualified LLVM.Extra.ScalarOrVector as SoV@@ -66,10 +69,10 @@ value = Expr.lift0 . MultiValue.cons  paramWith ::-   (Marshal.MV b) =>+   (Marshal.C b) =>    Param.T p b ->    (forall parameters.-    (Marshal.MV parameters) =>+    (Marshal.C parameters) =>     (p -> parameters) ->     (forall val. (Expr.Value val) =>      MultiValue.T parameters -> val b) ->@@ -79,7 +82,7 @@    Param.withMulti p (\get val -> f get (Expr.lift0 . val))  load ::-   (Marshal.MV sh) =>+   (Marshal.C sh) =>    f sh -> LLVM.Value (LLVM.Ptr (Marshal.Struct sh)) ->    LLVM.CodeGenFunction r (MultiValue.T sh) load _ = Memory.load@@ -91,7 +94,7 @@    (C sh) =>    MultiValue.T sh -> MultiValue.T (Index sh) ->    LLVM.CodeGenFunction r (LLVM.Value Size)-offset sh ix = ($ix) . snd =<< sizeOffset sh+offset sh ix = ($ ix) . snd =<< sizeOffset sh  class (MultiValue.C sh, MultiValue.C (Index sh), Shape.Indexed sh) => C sh where    {-@@ -261,13 +264,24 @@             IterMV.take len $ Iter.iterate MultiValue.inc from  +instance+      (Integral n, ToSize n, MultiValue.Comparison n) => C (Cyclic n) where+   intersectCode sha shb =+      cyclic <$> MultiValue.min (cyclicSize sha) (cyclicSize shb)+   size = toSize . cyclicSize+   sizeOffset sh = Monad.lift2 (,) (toSize $ cyclicSize sh) (return toSize)+   iterator sh =+      IterMV.take (cyclicSize sh) $+      Iter.iterate MultiValue.inc MultiValue.zero++ class (IterMV.Enum enum, MultiValue.Bounded enum) => EnumBounded enum where    enumOffset :: MultiValue.T enum -> LLVM.CodeGenFunction r (LLVM.Value Size)  instance    (ToSize w, MultiValue.Additive w,     LLVM.IsInteger w, SoV.IntegerConstant w, Num w,-    Tuple.ValueOf w ~ LLVM.Value w,+    MultiValue.Repr w ~ LLVM.Value w,     LLVM.CmpRet w, LLVM.IsPrimitive w,     Enum e, Bounded e) =>       EnumBounded (Enum.T w e) where
src/Data/Array/Knead/Shape/Cubic.hs view
@@ -31,9 +31,9 @@  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 LLVM.Extra.Multi.Iterator as IterMV-import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Iterator as Iter import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Tuple as Tuple@@ -76,7 +76,7 @@     Dec.Natural (Dec.FromUnary rank Dec.:*: LLVM.SizeOf Shape.Size)) =>    Param.T p (T tag rank) ->    (forall parameters.-    (Marshal.MV parameters) =>+    (Marshal.C parameters) =>     (p -> parameters) ->     (forall val. (Expr.Value val) =>      MultiValue.T parameters -> val (T tag rank)) ->@@ -207,19 +207,9 @@ toFixedList :: (Unary.Natural n) => [a] -> FixedLength.T n a toFixedList xs = snd $ Trav.mapAccumL (\(y:ys) () -> (ys,y)) xs (pure ()) -instance-   (Unary.Natural rank,-    Dec.Natural (Dec.FromUnary rank),-    Dec.Natural (Dec.FromUnary rank Dec.:*: LLVM.SizeOf Shape.Size)) =>-      Marshal.MV (T tag rank) where --instance (Unary.Natural rank) => Tuple.Value (T tag rank) where-   type ValueOf (T tag rank) = FixedLength.T rank (Tuple.ValueOf Index.Int)-   valueOf = fmap Tuple.valueOf . decons-- instance (Unary.Natural rank) => MultiValue.C (T tag rank) where+   type Repr (T tag rank) = FixedLength.T rank (MultiValue.Repr Index.Int)    cons = MultiValue.Cons . fmap (\(Index.Int i) -> LLVM.valueOf i) . decons    undef = constant $ MultiValue.undef    zero = constant $ MultiValue.zero@@ -248,9 +238,12 @@       Fold.and $       FixedLength.zipWith ComfortShape.inBounds          (shapeFromInt <$> sh) (indexFromInt <$> ix)-   offset (Cons sh) (Cons ix) =-      Fold.foldl'-         (\off (s,i) -> off * ComfortShape.size s + fromIntegral i) 0 $+   unifiedOffset (Cons sh) (Cons ix) =+      Fold.foldlM+         (\off (s,i) -> do+            ioff <- ComfortShape.unifiedOffset s i+            return $! off * ComfortShape.size s + ioff)+         0 $       FixedLength.zipWith (,) (shapeFromInt <$> sh) (indexFromInt <$> ix)  shapeFromInt :: Index.Int -> ZeroBased Shape.Size
src/Data/Array/Knead/Shape/Cubic/Int.hs view
@@ -6,9 +6,8 @@  import qualified Data.Array.Knead.Expression as Expr +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Arithmetic as A  import qualified LLVM.Core as LLVM@@ -34,11 +33,8 @@    switchSingle x = x  -instance Tuple.Value Int where-   type ValueOf Int = LLVM.Value Word-   valueOf (Int x) = LLVM.valueOf x- instance MultiValue.C Int where+   type Repr Int = LLVM.Value Word    cons (Int x) = MultiValue.consPrimitive x    undef = MultiValue.undefPrimitive    zero = MultiValue.zeroPrimitive@@ -69,5 +65,3 @@ instance Marshal.C Int where    pack (Int i) = i    unpack = Int--instance Marshal.MV Int where
src/Data/Array/Knead/Shape/Orphan.hs view
@@ -7,10 +7,11 @@ import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Shape          (ZeroBased(ZeroBased), Range(Range), Shifted(Shifted),+          Cyclic(Cyclic),           Enumeration(Enumeration)) +import qualified LLVM.Extra.Multi.Value.Marshal as Marshal import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Tuple as Tuple @@ -43,6 +44,7 @@    valueOf (ZeroBased n) = ZeroBased $ Tuple.valueOf n  instance (MultiValue.C n) => MultiValue.C (ZeroBased n) where+   type Repr (ZeroBased n) = ZeroBased (MultiValue.Repr n)    cons (ZeroBased n) = zeroBased (MultiValue.cons n)    undef = zeroBased MultiValue.undef    zero = zeroBased MultiValue.zero@@ -80,10 +82,8 @@    pack = Marshal.pack . Shape.zeroBasedSize    unpack = Shape.ZeroBased . Marshal.unpack -instance (Marshal.MV n) => Marshal.MV (ZeroBased n) where  - singletonRange :: n -> Range n singletonRange n = Range n n @@ -103,6 +103,7 @@    valueOf (Range from to) = Range (Tuple.valueOf from) (Tuple.valueOf to)  instance (MultiValue.C n) => MultiValue.C (Range n) where+   type Repr (Range n) = Range (MultiValue.Repr n)    cons (Range from to) = zipRange (MultiValue.cons from) (MultiValue.cons to)    undef = MultiValue.compose $ singletonRange MultiValue.undef    zero = MultiValue.compose $ singletonRange MultiValue.zero@@ -156,6 +157,7 @@       Shifted (Tuple.valueOf start) (Tuple.valueOf len)  instance (MultiValue.C n) => MultiValue.C (Shifted n) where+   type Repr (Shifted n) = Shifted (MultiValue.Repr n)    cons (Shifted start len) =       zipShifted (MultiValue.cons start) (MultiValue.cons len)    undef = MultiValue.compose $ singletonShifted MultiValue.undef@@ -193,11 +195,66 @@   -instance (Enum enum, Bounded enum) => Tuple.Value (Enumeration enum) where-   type ValueOf (Enumeration enum) = ()-   valueOf Enumeration = ()+unzipCyclic :: MultiValue.T (Cyclic n) -> Cyclic (MultiValue.T n)+unzipCyclic (MultiValue.Cons (Cyclic n)) = Cyclic (MultiValue.Cons n) +cyclicSize :: (Expr.Value val) => val (Cyclic n) -> val n+cyclicSize = Expr.lift1 $ Shape.cyclicSize . unzipCyclic++cyclic :: (Expr.Value val) => val n -> val (Cyclic n)+cyclic = Expr.lift1 $ \(MultiValue.Cons n) -> MultiValue.Cons (Cyclic n)++instance (Tuple.Undefined n) => Tuple.Undefined (Cyclic n) where+   undef = Cyclic Tuple.undef++instance (Tuple.Phi n) => Tuple.Phi (Cyclic n) where+   phi bb = fmap Cyclic . Tuple.phi bb . Shape.cyclicSize+   addPhi bb (Shape.Cyclic a) (Shape.Cyclic b) = Tuple.addPhi bb a b++instance (Tuple.Value n) => Tuple.Value (Cyclic n) where+   type ValueOf (Cyclic n) = Cyclic (Tuple.ValueOf n)+   valueOf (Cyclic n) = Cyclic $ Tuple.valueOf n++instance (MultiValue.C n) => MultiValue.C (Cyclic n) where+   type Repr (Cyclic n) = Cyclic (MultiValue.Repr n)+   cons (Cyclic n) = cyclic (MultiValue.cons n)+   undef = cyclic MultiValue.undef+   zero = cyclic MultiValue.zero+   phi bb = Monad.lift cyclic . MultiValue.phi bb . cyclicSize+   addPhi bb a b = MultiValue.addPhi bb (cyclicSize a) (cyclicSize b)++type instance+   MultiValue.Decomposed f (Cyclic pn) = Cyclic (MultiValue.Decomposed f pn)+type instance+   MultiValue.PatternTuple (Cyclic pn) = Cyclic (MultiValue.PatternTuple pn)++instance (MultiValue.Compose n) => MultiValue.Compose (Cyclic n) where+   type Composed (Cyclic n) = Cyclic (MultiValue.Composed n)+   compose (Cyclic n) = cyclic (MultiValue.compose n)++instance (MultiValue.Decompose pn) => MultiValue.Decompose (Cyclic pn) where+   decompose (Cyclic p) sh = MultiValue.decompose p <$> unzipCyclic sh++instance (Expr.Compose n) => Expr.Compose (Cyclic n) where+   type Composed (Cyclic n) = Cyclic (Expr.Composed n)+   compose (Cyclic n) = Expr.lift1 cyclic (Expr.compose n)++instance (Expr.Decompose pn) => Expr.Decompose (Cyclic pn) where+   decompose (Cyclic p) = Cyclic . Expr.decompose p . cyclicSize++instance (Memory.C n) => Memory.C (Cyclic n) where+   type Struct (Cyclic n) = Memory.Struct n+   compose = Memory.compose . Shape.cyclicSize+   decompose = fmap Cyclic . Memory.decompose++instance (Marshal.C n) => Marshal.C (Cyclic n) where+   pack = Marshal.pack . Shape.cyclicSize+   unpack = Shape.Cyclic . Marshal.unpack+++ instance (Enum enum, Bounded enum) => MultiValue.C (Enumeration enum) where+   type Repr (Enumeration enum) = ()    cons = MultiValue.consUnit    undef = MultiValue.undefUnit    zero = MultiValue.zeroUnit
− src/Data/Array/Knead/Simple/Fold.hs 
@@ -1,98 +0,0 @@-{- |-Reduce selected dimensions.-Alternatively you may reorder dimensions with 'ShapeDep.backpermute'-and fold once along multiple dimensions.--}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-module Data.Array.Knead.Simple.Fold (-   T,-   Cubic,-   apply,-   passAny,-   pass,-   fold,-   (Core.$:.),-   ) where--import qualified Data.Array.Knead.Simple.Private as Core-import Data.Array.Knead.Simple.Private (Array(Array), Code, Val, )--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.Shape.Cubic ((#:.), (:.)((:.)), )--import LLVM.DSL.Expression (Exp, unExp)--import qualified LLVM.Extra.Multi.Value as MultiValue-import LLVM.Extra.Multi.Value (atom, )--import qualified Type.Data.Num.Unary as Unary--import Prelude hiding (zipWith, zipWith3, zip, zip3, replicate, )---data T sh0 sh1 a =-   forall ix0 ix1.-   (Shape.Index sh0 ~ ix0, Shape.Index sh1 ~ ix1) =>-   Cons-      (Exp sh0 -> Exp sh1)-      (forall r. Val sh0 -> (Val ix0 -> Code r a) -> (Val ix1 -> Code r a))---apply ::-   (Core.C array, Shape.C sh0, Shape.C sh1, MultiValue.C a) =>-   T sh0 sh1 a ->-   array sh0 a ->-   array sh1 a-apply (Cons fsh reduce) =-   Core.lift1 $ \(Array sh code) ->-      Array (fsh sh) (\ix -> do sh0 <- unExp sh; reduce sh0 code ix)---type Cubic rank0 rank1 = T (Cubic.Shape rank0) (Cubic.Shape rank1)--passAny :: Cubic rank rank a-passAny = Cons id (const id)--pass ::-   (Unary.Natural rank0, Unary.Natural rank1, MultiValue.C a) =>-   Cubic rank0 rank1 a ->-   Cubic (Unary.Succ rank0) (Unary.Succ rank1) a-pass (Cons fsh reduce) =-   Cons-      (Expr.modify (atom:.atom) $ \(sh:.s) -> fsh sh :. s)-      (\sh code ->-       Cubic.switchR $ \jx j ->-          reduce (Cubic.tail sh) (\kx -> code (kx #:. j)) jx)---fold1CodeLinear ::-   (Unary.Natural rank, MultiValue.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Exp Index.Int ->-   (Val (Cubic.Index (Unary.Succ rank)) -> Code r a) ->-   (Val (Cubic.Index rank) -> Code r a)-fold1CodeLinear f nc code ix =-   Core.fold1Code f-      (Expr.lift1 (MultiValue.compose . Shape.ZeroBased) $ Index.decons nc)-      (\j -> code (ix #:. Index.cons j))--fold ::-   (Unary.Natural rank0, Unary.Natural rank1, MultiValue.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Cubic rank0 rank1 a ->-   Cubic (Unary.Succ rank0) rank1 a-fold f (Cons fsh reduce) =-   Cons-      (fsh . Cubic.tail)-      (\sh code jx ->-          reduce (Cubic.tail sh)-             (fold1CodeLinear f (Expr.lift0 (Cubic.head sh)) code) jx)---instance Core.Process (T sh0 sh1 a) where
− src/Data/Array/Knead/Simple/Physical.hs 
@@ -1,195 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Data.Array.Knead.Simple.Physical (-   Array,-   shape,-   toList,-   fromList,-   vectorFromList,-   with,-   render,-   scanl1,-   mapAccumLSimple,-   scatter,-   scatterMaybe,-   permute,-   ) where--import qualified Data.Array.Knead.Simple.PhysicalPrivate as Priv-import qualified Data.Array.Knead.Simple.Private as Sym-import qualified Data.Array.Knead.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Simple.PhysicalPrivate (MarshalPtr)-import Data.Array.Knead.Code (getElementPtr)--import qualified LLVM.DSL.Execution as Code-import LLVM.DSL.Expression (Exp, unExp)--import qualified Data.Array.Comfort.Storable.Mutable.Unchecked as MutArray-import qualified Data.Array.Comfort.Storable.Unchecked as Array-import qualified Data.Array.Comfort.Shape as ComfortShape-import Data.Array.Comfort.Storable.Unchecked (Array(Array))--import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Maybe as Maybe--import qualified LLVM.Core as LLVM--import Foreign.Storable (Storable, )-import Foreign.ForeignPtr (withForeignPtr, mallocForeignPtrArray, )-import Foreign.Ptr (FunPtr, Ptr, )--import Control.Monad.HT (void, (<=<), )-import Control.Applicative (liftA2, (<$>), )--import Prelude2010 hiding (scanl1)-import Prelude ()---shape :: Array sh a -> sh-shape = Array.shape--toList ::-   (Shape.C sh, Storable a) =>-   Array sh a -> IO [a]-toList = MutArray.toList <=< MutArray.unsafeThaw--fromList ::-   (Shape.C sh, Storable a) =>-   sh -> [a] -> IO (Array sh a)-fromList sh = MutArray.unsafeFreeze <=< MutArray.fromList sh--vectorFromList ::-   (Num n, Storable a) =>-   [a] -> IO (Array (ComfortShape.ZeroBased n) a)-vectorFromList xs =-   Array.mapShape (\(Shape.ZeroBased n) -> Shape.ZeroBased $ fromIntegral n) <$>-   (MutArray.unsafeFreeze =<< MutArray.vectorFromList xs)---{- |-The symbolic array is only valid inside the enclosed action.--}-with ::-   (Shape.C sh, Storable.C a) =>-   (Sym.Array sh a -> IO b) ->-   Array sh a -> IO b-with f (Array sh fptr) =-   withForeignPtr fptr $ \ptr ->-      f $-      Sym.Array-         (Shape.value sh)-         (\ix ->-            Storable.loadMultiValue =<<-               getElementPtr (Shape.value sh) (LLVM.valueOf ptr) ix)---type Importer f = FunPtr f -> f--foreign import ccall safe "dynamic" callShaper ::-   Importer (LLVM.Ptr sh -> IO Shape.Size)--foreign import ccall safe "dynamic" callRenderer ::-   Importer (LLVM.Ptr sh -> Ptr a -> IO ())---materialize ::-   (Shape.C sh, Marshal.MV sh, Storable.C a) =>-   String ->-   Exp sh ->-   (LLVM.Value (MarshalPtr sh) ->-    LLVM.Value (Ptr a) -> LLVM.CodeGenFunction () ()) ->-   IO (Array sh a)-materialize name esh code =-   Marshal.alloca $ \lshptr -> do-      (fsh, farr) <--         Code.compile name $-         liftA2 (,)-            (Code.createFunction callShaper "shape" $ \ptr -> do-               sh <- unExp esh-               Memory.store sh ptr-               Shape.size sh >>= LLVM.ret)-            (Code.createFunction callRenderer "fill"-               (\paramPtr arrayPtr -> code paramPtr arrayPtr >> LLVM.ret ()))-      n <- fsh lshptr-      fptr <- mallocForeignPtrArray (fromIntegral n)-      withForeignPtr fptr $ farr lshptr-      sh <- Marshal.peek lshptr-      return (Array sh fptr)--render ::-   (Shape.C sh, Marshal.MV sh, Storable.C a) =>-   Sym.Array sh a -> IO (Array sh a)-render (Sym.Array esh code) =-   materialize "render" esh $ \sptr ptr -> do-      let step ix p = flip Storable.storeNextMultiValue p =<< code ix-      sh <- Shape.load esh sptr-      void $ Shape.loop step sh ptr--scanl1 ::-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,-    Storable.C a, MultiValue.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array (sh, n) a -> IO (Array (sh, n) a)-scanl1 f (Sym.Array esh code) =-   materialize "scanl1" esh $ \sptr ptr -> do-      (sh, n) <- MultiValue.unzip <$> Shape.load esh sptr-      let step ix ptrStart =-             fmap fst $-             (\body -> Shape.loop body n (ptrStart, Maybe.nothing)) $-                   \k0 (ptr0, macc0) -> do-                a <- code $ MultiValue.zip ix k0-                acc1 <- Maybe.run macc0 (return a) (flip (Expr.unliftM2 f) a)-                ptr1 <- Storable.storeNextMultiValue acc1 ptr0-                return (ptr1, Maybe.just acc1)-      void $ Shape.loop step sh ptr--mapAccumLSimple ::-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,-    MultiValue.C acc, Storable.C x, Storable.C y) =>-   (Exp acc -> Exp x -> Exp (acc,y)) ->-   Sym.Array sh acc -> Sym.Array (sh, n) x -> IO (Array (sh, n) y)-mapAccumLSimple f arrInit arrData =-   materialize "mapAccumLSimple" (Sym.shape arrData) $-      Priv.mapAccumLSimple f arrInit arrData--scatterMaybe ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,-    Storable.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array sh1 a ->-   Sym.Array sh0 (Maybe (ix1, a)) -> IO (Array sh1 a)-scatterMaybe accum arrInit arrMap =-   materialize "scatterMaybe" (Sym.shape arrInit) $-      Priv.scatterMaybe accum arrInit arrMap--scatter ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,-    Storable.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array sh1 a ->-   Sym.Array sh0 (ix1, a) -> IO (Array sh1 a)-scatter accum arrInit arrMap =-   materialize "scatter" (Sym.shape arrInit) $-      Priv.scatter accum arrInit arrMap--permute ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,-    Storable.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array sh1 a ->-   (Exp ix0 -> Exp ix1) ->-   Sym.Array sh0 a ->-   IO (Array sh1 a)-permute accum deflt ixmap input =-   scatter accum deflt-      (Sym.mapWithIndex (Expr.lift2 MultiValue.zip . ixmap) input)
− src/Data/Array/Knead/Simple/PhysicalPrivate.hs 
@@ -1,258 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module Data.Array.Knead.Simple.PhysicalPrivate where--import qualified Data.Array.Knead.Simple.Private as Sym-import qualified Data.Array.Knead.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Code (getElementPtr)--import LLVM.DSL.Expression (Exp, unExp)--import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Marshal as Marshal-import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Control as C--import qualified LLVM.Core as LLVM--import Foreign.Ptr (Ptr, )--import qualified Control.Applicative.HT as App-import Control.Monad.HT (void, )-import Control.Applicative ((<$>), )--import Data.Tuple.HT (mapSnd, )--import Prelude2010-import Prelude ()----type MarshalPtr a = LLVM.Ptr (Marshal.Struct a)--writeArray ::-   (Shape.C sh, Shape.Index sh ~ ix, Storable.C a) =>-   MultiValue.T sh ->-   (MultiValue.T ix -> LLVM.CodeGenFunction r (MultiValue.T a)) ->-   LLVM.Value (Ptr a) ->-   LLVM.CodeGenFunction r (LLVM.Value (Ptr a))-writeArray sh code ptr = do-   let clear ix p = flip Storable.storeNextMultiValue p =<< code ix-   Shape.loop clear sh ptr---mapAccumLLoop ::-   (MultiValue.C acc, Storable.C b,-    Shape.C sh, Shape.Index sh ~ ix) =>-   (MultiValue.T ix -> LLVM.CodeGenFunction r (MultiValue.T a)) ->-   (Exp acc -> Exp a -> Exp (acc, b)) ->-   MultiValue.T sh ->-   LLVM.Value (Ptr b) -> MultiValue.T acc ->-   LLVM.CodeGenFunction r (LLVM.Value (Ptr b), MultiValue.T acc)-mapAccumLLoop code f n yPtr accInit = do-   let step k0 (ptr0, acc0) = do-         x <- code k0-         (acc1,y) <- MultiValue.unzip <$> Expr.unliftM2 f acc0 x-         ptr1 <- Storable.storeNextMultiValue y ptr0-         return (ptr1, acc1)-   Shape.loop step n (yPtr, accInit)--mapAccumLSimple ::-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,-    MultiValue.C acc,-    Storable.C x,-    Storable.C y) =>-   (Exp acc -> Exp x -> Exp (acc,y)) ->-   Sym.Array sh acc -> Sym.Array (sh, n) x ->-   LLVM.Value (MarshalPtr (sh,n)) ->-   LLVM.Value (Ptr y) ->-   LLVM.CodeGenFunction r ()-mapAccumLSimple f (Sym.Array _ initCode) (Sym.Array esh code) sptr ptr = do-   (sh, n) <- MultiValue.unzip <$> Shape.load esh sptr-   let step ix ptrStart = do-         accInit <- initCode ix-         fst <$> mapAccumLLoop (code . MultiValue.zip ix) f n ptrStart accInit-   void $ Shape.loop step sh ptr--mapAccumLSequence ::-   (Shape.C n, Marshal.MV n,-    MultiValue.C acc, Storable.C final,-    Storable.C x,-    Storable.C y) =>-   (Exp acc -> Exp x -> Exp (acc,y)) ->-   (Exp acc -> Exp final) ->-   Exp acc -> Sym.Array n x ->-   LLVM.Value (Ptr final) ->-   LLVM.Value (MarshalPtr n) ->-   LLVM.Value (Ptr y) ->-   LLVM.CodeGenFunction r ()-mapAccumLSequence f final initExp (Sym.Array esh code) accPtr sptr yPtr = do-   n <- Shape.load esh sptr-   accInit <- unExp initExp-   accExit <- snd <$> mapAccumLLoop code f n yPtr accInit-   flip Storable.storeMultiValue accPtr =<< Expr.unliftM1 final accExit--mapAccumL ::-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,-    MultiValue.C acc, Storable.C final,-    Storable.C x,-    Storable.C y) =>-   (Exp acc -> Exp x -> Exp (acc,y)) ->-   (Exp acc -> Exp final) ->-   Sym.Array sh acc -> Sym.Array (sh, n) x ->-   (LLVM.Value (MarshalPtr sh), LLVM.Value (Ptr final)) ->-   (LLVM.Value (MarshalPtr (sh,n)), LLVM.Value (Ptr y)) ->-   LLVM.CodeGenFunction r ()-mapAccumL f final (Sym.Array _ initCode) (Sym.Array esh code)-      (_, accPtr) (sptr, yPtr) = do-   (sh, n) <- MultiValue.unzip <$> Shape.load esh sptr-   let step ix (accPtr0, yPtrStart) = do-         accInit <- initCode ix-         (ptrStop, accExit) <--            mapAccumLLoop (code . MultiValue.zip ix) f n yPtrStart accInit-         accPtr1 <--            flip Storable.storeNextMultiValue accPtr0-               =<< Expr.unliftM1 final accExit-         return (accPtr1, ptrStop)-   void $ Shape.loop step sh (accPtr,yPtr)--foldOuterL ::-   (Shape.C sh, Marshal.MV sh,-    Shape.C n, Marshal.MV n,-    Storable.C a) =>-   (Exp a -> Exp b -> Exp a) ->-   Sym.Array sh a -> Sym.Array (n,sh) b ->-   LLVM.Value (MarshalPtr sh) ->-   LLVM.Value (Ptr a) ->-   LLVM.CodeGenFunction r ()-foldOuterL f (Sym.Array _ initCode) (Sym.Array esh code) sptr ptr = do-   sh <- Shape.load (Expr.snd esh) sptr-   n <- MultiValue.fst <$> unExp esh-   void $ writeArray sh initCode ptr--   let step k ix ptr0 = do-         b <- code $ MultiValue.zip k ix-         a0 <- Storable.loadMultiValue ptr0-         a1 <- Expr.unliftM2 f a0 b-         Storable.storeNextMultiValue a1 ptr0-   void $ Shape.loop (\k () -> void $ Shape.loop (step k) sh ptr) n ()--{- |-We need a scalar Shape type @n@.-Scalar Shape types could be distinguished from other Shape types-by the fact that you can convert any Index into a Shape.--}-mapFilter ::-   (Shape.Sequence n, Marshal.MV n,-    Storable.C b) =>-   (Exp a -> Exp b) ->-   (Exp a -> Exp Bool) ->-   Sym.Array n a ->-   LLVM.Value (MarshalPtr n) ->-   LLVM.Value (Ptr b) ->-   LLVM.CodeGenFunction r (MultiValue.T n)-mapFilter f p (Sym.Array esh code) sptr ptr = do-   n <- Shape.load esh sptr-   let step ix (dstPtr,dstIx) = do-         a <- code ix-         MultiValue.Cons c <- Expr.unliftM1 p a-         C.ifThen c (dstPtr,dstIx)-            (App.lift2 (,)-               (flip Storable.storeNextMultiValue dstPtr =<< Expr.unliftM1 f a)-               (MultiValue.inc dstIx))-   Shape.sequenceShapeFromIndex . snd-      =<< Shape.loop step n (ptr, MultiValue.zero)--filterOuter ::-   (Shape.Sequence n, Marshal.MV n,-    Shape.C sh, Marshal.MV sh,-    Storable.C a) =>-   Sym.Array n Bool ->-   Sym.Array (n,sh) a ->-   LLVM.Value (MarshalPtr (n,sh)) ->-   LLVM.Value (Ptr a) ->-   LLVM.CodeGenFunction r (MultiValue.T (n,sh))-filterOuter (Sym.Array _eish selectCode) (Sym.Array esh code) sptr ptr = do-   (n,sh) <- MultiValue.unzip <$> Shape.load esh sptr-   let step k (dstPtr0,dstK) = do-         MultiValue.Cons c <- selectCode k-         C.ifThen c (dstPtr0,dstK)-            (do-               dstPtr1 <- writeArray sh (code . MultiValue.zip k) dstPtr0-               (,) dstPtr1 <$> MultiValue.inc dstK)-   finalN <--      Shape.sequenceShapeFromIndex . snd-         =<< Shape.loop step n (ptr, MultiValue.zero)-   return $ MultiValue.zip finalN sh---scatterMaybe ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Marshal.MV sh1,-    Storable.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array sh1 a -> Sym.Array sh0 (Maybe (ix1, a)) ->-   LLVM.Value (MarshalPtr sh1) ->-   LLVM.Value (Ptr a) ->-   LLVM.CodeGenFunction r ()-scatterMaybe accum (Sym.Array esh codeInit) (Sym.Array eish codeMap)-      sptr ptr = do--   sh <- Shape.load esh sptr-   void $ writeArray sh codeInit ptr--   ish <- unExp eish-   let fill ix () = do-         (MultiValue.Cons c, (jx, a)) <--            mapSnd MultiValue.unzip . MultiValue.splitMaybe <$> codeMap ix-         C.ifThen c () $ do-            p <- getElementPtr sh ptr jx-            flip Storable.storeMultiValue p-               =<< Expr.unliftM2 (flip accum) a-               =<< Storable.loadMultiValue p-   Shape.loop fill ish ()--scatter ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Marshal.MV sh1,-    Storable.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array sh1 a ->-   Sym.Array sh0 (Shape.Index sh1, a) ->-   LLVM.Value (MarshalPtr sh1) ->-   LLVM.Value (Ptr a) ->-   LLVM.CodeGenFunction r ()-scatter accum (Sym.Array esh codeInit) (Sym.Array eish codeMap) sptr ptr = do-   sh <- Shape.load esh sptr-   void $ writeArray sh codeInit ptr--   ish <- unExp eish-   let fill ix () = do-         (jx, a) <- MultiValue.unzip <$> codeMap ix-         p <- getElementPtr sh ptr jx-         flip Storable.storeMultiValue p-            =<< Expr.unliftM2 (flip accum) a-            =<< Storable.loadMultiValue p-   Shape.loop fill ish ()--addDimension ::-   (Shape.C n, Marshal.MV n, Shape.Index n ~ k,-    Shape.C sh, Marshal.MV sh,-    Storable.C b) =>-   Exp n ->-   (Exp k -> Exp a -> Exp b) ->-   Sym.Array sh a ->-   LLVM.Value (MarshalPtr (sh,n)) ->-   LLVM.Value (Ptr b) ->-   LLVM.CodeGenFunction r ()-addDimension en select (Sym.Array esh code) sptr ptr = do-   (sh,n) <- MultiValue.unzip <$> Shape.load (Expr.zip esh en) sptr--   let fill ix ptr0 = do-         a <- code ix-         writeArray n (\k -> Expr.unliftM2 select k a) ptr0-   void $ Shape.loop fill sh ptr
− src/Data/Array/Knead/Simple/Private.hs 
@@ -1,203 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-module Data.Array.Knead.Simple.Private where--import qualified Data.Array.Knead.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr--import LLVM.DSL.Expression (Exp(Exp))--import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Iterator as Iter-import qualified LLVM.Extra.Maybe as Maybe-import qualified LLVM.Core as LLVM--import qualified Control.Category as Cat-import qualified Control.Monad.HT as Monad-import Control.Monad ((<=<), )--import Prelude hiding (id, map, zipWith, replicate, )---type Val = MultiValue.T-type Code r a = LLVM.CodeGenFunction r (Val a)--data Array sh a =-   Array (Exp sh) (forall r. Val (Shape.Index sh) -> Code r a)--shape :: Array sh a -> Exp sh-shape (Array sh _) = sh--(!) ::-   (Shape.C sh,  Shape.Index sh  ~ ix) =>-   Array sh a -> Exp ix -> Exp a-(!) (Array _ code) (Exp ix) = Exp (code =<< ix)--the :: (Shape.Scalar sh) => Array sh a -> Exp a-the (Array z code) = Exp (code $ Shape.zeroIndex z)--fromScalar :: (Shape.Scalar sh) => Exp a -> Array sh a-fromScalar = fill Shape.scalar---fill :: Exp sh -> Exp a -> Array sh a-fill sh (Exp code) = Array sh (\_z -> code)---{- |-This class allows to implement functions without parameters-for both simple and parameterized arrays.--}-class C array where-   lift0 :: Array sh a -> array sh a-   lift1 :: (Array sha a -> Array shb b) -> array sha a -> array shb b-   lift2 ::-      (Array sha a -> Array shb b -> Array shc c) ->-      array sha a -> array shb b -> array shc c--instance C Array where-   lift0 = Cat.id-   lift1 = Cat.id-   lift2 = Cat.id---gather ::-   (C array,-    Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    MultiValue.C a) =>-   array sh1 ix0 ->-   array sh0 a ->-   array sh1 a-gather =-   lift2 $ \(Array sh1 f) (Array _sh0 code) ->-      Array sh1 (code <=< f)--backpermute2 ::-   (C array,-    Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Shape.C sh,  Shape.Index sh  ~ ix) =>-   Exp sh ->-   (Exp ix -> Exp ix0) ->-   (Exp ix -> Exp ix1) ->-   (Exp a -> Exp b -> Exp c) ->-   array sh0 a -> array sh1 b -> array sh c-backpermute2 sh projectIndex0 projectIndex1 f =-   lift2 $ \(Array _sha codeA) (Array _shb codeB) ->-      Array sh-         (\ix ->-            Monad.liftJoin2 (Expr.unliftM2 f)-               (codeA =<< Expr.unliftM1 projectIndex0 ix)-               (codeB =<< Expr.unliftM1 projectIndex1 ix))---id ::-   (C array, Shape.C sh, Shape.Index sh ~ ix) =>-   Exp sh -> array sh ix-id sh = lift0 $ Array sh return--map ::-   (C array, Shape.C sh) =>-   (Exp a -> Exp b) ->-   array sh a -> array sh b-map f =-   lift1 $ \(Array sh code) ->-      Array sh (Expr.unliftM1 f <=< code)--mapWithIndex ::-   (C array, Shape.C sh, Shape.Index sh ~ ix) =>-   (Exp ix -> Exp a -> Exp b) ->-   array sh a -> array sh b-mapWithIndex f =-   lift1 $ \(Array sh code) ->-      Array sh (\ix -> Expr.unliftM2 f ix =<< code ix)---fold1Code ::-   (Shape.C sh, Shape.Index sh ~ ix, MultiValue.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Exp sh ->-   (Val ix -> Code r a) ->-   Code r a-fold1Code f (Exp nc) code = do-   n <- nc-   fmap Maybe.fromJust $-      Shape.loop-         (\i0 macc0 -> do-            a <- code i0-            acc1 <- Maybe.run macc0 (return a) (flip (Expr.unliftM2 f) a)-            return $ Maybe.just acc1)-         n Maybe.nothing--fold1 ::-   (C array, Shape.C sh0, Shape.C sh1, MultiValue.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   array (sh0, sh1) a -> array sh0 a-fold1 f =-   lift1 $ \(Array shs code) ->-      case Expr.unzip shs of-         (sh, s) -> Array sh $ fold1Code f s . MultiValue.curry code---fold1All ::-   (Shape.C sh, MultiValue.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Array sh a -> Exp a-fold1All f (Array sh code) = Exp (fold1Code f sh code)---findAllCode ::-   (Shape.C sh, Shape.Index sh ~ ix, MultiValue.C a) =>-   (Exp a -> Exp Bool) ->-   Exp sh ->-   (Val ix -> Code r a) ->-   Code r (Maybe a)-findAllCode p (Exp sh) code = do-   n <- sh-   finalFound <--      Iter.mapWhileState_-         (\a _found -> do-            MultiValue.Cons b <- Expr.unliftM1 p a-            notb <- LLVM.inv b-            return (notb, Maybe.fromBool b a))-         (Iter.mapM code $ Shape.iterator n)-         Maybe.nothing-   Maybe.run finalFound-      (return MultiValue.nothing)-      (return . MultiValue.just)--{- |-In principle this can be implemented using fold1All-but it has a short-cut semantics.-@All@ means that it scans all dimensions-but it does not mean that it finds all occurrences.-If you want to get the index of the found element,-please decorate the array elements with their indices before calling 'findAll'.--}-findAll ::-   (Shape.C sh, MultiValue.C a) =>-   (Exp a -> Exp Bool) ->-   Array sh a -> Exp (Maybe a)-findAll p (Array sh code) = Exp (findAllCode p sh code)---class Process proc where---infixl 3 $:.--{- |-Use this for combining several dimension manipulators.-E.g.--> apply (passAny $:. pick 3 $:. pass $:. replicate 10) array--The constraint @(Process proc0, Process proc1)@ is a bit weak.-We like to enforce that the type constructor like @Slice.T@-is the same in @proc0@ and @proc1@, and only the parameters differ.-Currently this coherence is achieved,-because we only provide functions of type @proc0 -> proc1@ with this condition.--}-($:.) :: (Process proc0, Process proc1) => proc0 -> (proc0 -> proc1) -> proc1-($:.) = flip ($)
− src/Data/Array/Knead/Simple/ShapeDependent.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module Data.Array.Knead.Simple.ShapeDependent where--import qualified Data.Array.Knead.Simple.Private as Core-import Data.Array.Knead.Simple.Private (Array(Array), )--import qualified Data.Array.Knead.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, )--import qualified Control.Monad.HT as Monad-import Control.Monad ((<=<), )---shape :: (Core.C array, Shape.C sh, Shape.Scalar z) => array sh a -> array z sh-shape = Core.lift1 $ Core.fromScalar . Core.shape--backpermute ::-   (Core.C array,-    Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1) =>-   (Exp sh0 -> Exp sh1) ->-   (Exp ix1 -> Exp ix0) ->-   array sh0 a ->-   array sh1 a-backpermute createShape projectIndex =-   Core.lift1 $ \(Array sh code) ->-      Array (createShape sh)-         (code <=< Expr.unliftM1 projectIndex)--{- |-This is between 'backpermute' and 'backpermute2'.-You can access the shapes of two arrays,-but only the content of one of them.-This is necessary if the second array contributes only a virtual dimension.--}-backpermuteExtra ::-   (Core.C array,-    Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Shape.C sh,  Shape.Index sh  ~ ix) =>-   (Exp sh0 -> Exp sh1 -> Exp sh) ->-   (Exp ix -> Exp ix0) ->-   array sh0 a -> array sh1 b -> array sh a-backpermuteExtra newShape projectIndex =-   Core.lift2 $ \(Array sh0 code) (Array sh1 _code) ->-      Array (newShape sh0 sh1)-         (\ix -> code =<< Expr.unliftM1 projectIndex ix)--backpermute2 ::-   (Core.C array,-    Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Shape.C sh,  Shape.Index sh  ~ ix) =>-   (Exp sh0 -> Exp sh1 -> Exp sh) ->-   (Exp ix -> Exp ix0) ->-   (Exp ix -> Exp ix1) ->-   (Exp a -> Exp b -> Exp c) ->-   array sh0 a -> array sh1 b -> array sh c-backpermute2 combineShape projectIndex0 projectIndex1 f =-   Core.lift2 $ \(Array sha codeA) (Array shb codeB) ->-      Array (combineShape sha shb)-         (\ix ->-            Monad.liftJoin2 (Expr.unliftM2 f)-               (codeA =<< Expr.unliftM1 projectIndex0 ix)-               (codeB =<< Expr.unliftM1 projectIndex1 ix))--fill ::-   (Core.C array) =>-   (Exp sh0 -> Exp sh1) -> Exp b ->-   array sh0 a -> array sh1 b-fill fsh a =-   Core.lift1 $ \arr ->-      Core.fill (fsh $ Core.shape arr) a
− src/Data/Array/Knead/Simple/Slice.hs 
@@ -1,198 +0,0 @@-{- |-Generate and apply index maps.-This unifies the @replicate@ and @slice@ functions of the @accelerate@ package.-However the structure of slicing and replicating cannot depend on parameters.-If you need that, you must use 'ShapeDep.backpermute' and friends.--}-{--Some notes on the design choice:--Instead of the shallow embedding implemented by the 'T' type,-we could maintain a symbolic representation of the Slice and Replicate pattern,-like the accelerate package does.-We actually used that representation in former versions.-It has however some drawbacks:--* We need additional type functions that map from the pattern-  to the source and the target shape and we need a proof,-  that the images of these type functions are actually shapes.-  This worked already, but was rather cumbersome.--* We need a way to store and pass this pattern through the Parameter handler.-  This yields new problems:-  We need a wrapper type for wrapping Index, Shape, Slice, Replicate, Fold patterns.-  Then the question is whether we use one Wrap type with a phantom parameter-  or whether we define a Wrap type for every pattern type.-  That is, the options are to write either--  > Wrap Shape (Z:.Int:.Int)--  or--  > Shape (Z:.Int:.Int)--  The first one seems to save us many duplicate instances of-  Storable, MultiValue etc.-  and it allows us easily to reuse the (:.) for all kinds of patterns.-  However, we need a way to restrict the element type of the (:.)-list elements.-  We can define that using variable ConstraintKinds,-  but e.g. we are not able to add a Storable superclass constraint-  to the instance Storable (Wrap constr).-  That is, we are left with the second option-  and had to define a lot of similar Storable, MultiValue instances.--}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-module Data.Array.Knead.Simple.Slice (-   T,-   Cubic,-   apply,-   passAny,-   pass,-   pick,-   pickFst,-   pickSnd,-   extrude,-   extrudeFst,-   extrudeSnd,-   transpose,-   (Core.$:.),--   id,-   first,-   second,-   compose,-   ) where--import qualified Data.Array.Knead.Simple.ShapeDependent as ShapeDep-import qualified Data.Array.Knead.Simple.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.Shape.Cubic ((#:.), (:.)((:.)), )-import Data.Array.Knead.Expression (Exp, )--import qualified LLVM.Extra.Multi.Value as MultiValue-import LLVM.Extra.Multi.Value (atom, )--import qualified Type.Data.Num.Unary as Unary--import qualified Prelude as P-import Prelude hiding (id, zipWith, zipWith3, zip, zip3, replicate, )----{--This data type is almost identical to Core.Array.-The only difference is,-that the shape @sh1@ in T can depend on another shape @sh0@.--}-data T sh0 sh1 =-   forall ix0 ix1.-   (Shape.Index sh0 ~ ix0, Shape.Index sh1 ~ ix1) =>-   Cons-      (Exp sh0 -> Exp sh1)-      (Exp ix1 -> Exp ix0)--{- |-This is essentially a 'ShapeDep.backpermute'.--}-apply ::-   (Core.C array, Shape.C sh0, Shape.C sh1, MultiValue.C a) =>-   T sh0 sh1 ->-   array sh0 a ->-   array sh1 a-apply (Cons fsh fix) =-   ShapeDep.backpermute fsh fix---pickFst :: Exp (Shape.Index n) -> T (n,sh) sh-pickFst i = Cons Expr.snd (Expr.zip i)--pickSnd :: Exp (Shape.Index n) -> T (sh,n) sh-pickSnd i = Cons Expr.fst (flip Expr.zip i)--{- |-Extrusion has the potential to do duplicate work.-Only use it to add dimensions of size 1, e.g. numeric 1 or unit @()@-or to duplicate slices of physical arrays.--}-extrudeFst :: Exp n -> T sh (n,sh)-extrudeFst n = Cons (Expr.zip n) Expr.snd--extrudeSnd :: Exp n -> T sh (sh,n)-extrudeSnd n = Cons (flip Expr.zip n) Expr.fst--transpose :: T (sh0,sh1) (sh1,sh0)-transpose = Cons Expr.swap Expr.swap----- Arrow combinators--id :: T sh sh-id = Cons P.id P.id--first :: T sh0 sh1 -> T (sh0,sh) (sh1,sh)-first (Cons fsh fix) = Cons (Expr.mapFst fsh) (Expr.mapFst fix)--second :: T sh0 sh1 -> T (sh,sh0) (sh,sh1)-second (Cons fsh fix) = Cons (Expr.mapSnd fsh) (Expr.mapSnd fix)--infixr 1 `compose`--compose :: T sh0 sh1 -> T sh1 sh2 -> T sh0 sh2-compose (Cons fshA fixA) (Cons fshB fixB) = Cons (fshB . fshA) (fixA . fixB)---type Cubic rank0 rank1 = T (Cubic.Shape rank0) (Cubic.Shape rank1)--{- |-Like @Any@ in @accelerate@.--}-passAny :: Cubic rank rank-passAny = Cons P.id P.id--{- |-Like @All@ in @accelerate@.--}-pass ::-   (Unary.Natural rank0, Unary.Natural rank1) =>-   Cubic rank0 rank1 ->-   Cubic (Unary.Succ rank0) (Unary.Succ rank1)-pass (Cons fsh fix) =-   Cons-      (Expr.modify (atom:.atom) $ \(sh:.s) -> fsh sh :. s)-      (Expr.modify (atom:.atom) $ \(ix:.i) -> fix ix :. i)--{- |-Like @Int@ in @accelerate/slice@.--}-pick ::-   (Unary.Natural rank0, Unary.Natural rank1) =>-   Exp Index.Int ->-   Cubic rank0 rank1 ->-   Cubic (Unary.Succ rank0) rank1-pick i (Cons fsh fix) =-   Cons-      (fsh . Cubic.tail)-      (\ix -> fix ix #:. i)--{- |-Like @Int@ in @accelerate/replicate@.--}-extrude ::-   (Unary.Natural rank0, Unary.Natural rank1) =>-   Exp Index.Int ->-   Cubic rank0 rank1 ->-   Cubic rank0 (Unary.Succ rank1)-extrude n (Cons fsh fix) =-   Cons-      (\sh -> fsh sh #:. n)-      (fix . Cubic.tail)---instance Core.Process (T sh0 sh1) where
− src/Data/Array/Knead/Simple/Symbolic.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE GADTs #-}-module Data.Array.Knead.Simple.Symbolic (-   Core.Array,-   Core.C(..),-   Exp,-   fix,-   shape,-   (Core.!),-   Core.the,-   Core.fromScalar,-   Core.fill,-   gather,-   backpermute,-   Core.backpermute2,-   Core.id,-   Core.map,-   Core.mapWithIndex,-   zipWith,-   zipWith3,-   zipWith4,-   zip,-   zip3,-   zip4,-   Core.fold1,-   Core.fold1All,-   Core.findAll,-   ) where--import qualified Data.Array.Knead.Simple.ShapeDependent as ShapeDep-import qualified Data.Array.Knead.Simple.Private as Core-import Data.Array.Knead.Simple.Private (Array, shape, 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.Extra.Multi.Value as MultiValue--import Data.Function.HT (Id)--import Prelude hiding (zipWith, zipWith3, zip, zip3, replicate, )---fix :: Id (Array sh a)-fix = id--backpermute ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    MultiValue.C a) =>-   Exp sh1 ->-   (Exp ix1 -> Exp ix0) ->-   Array sh0 a ->-   Array sh1 a-backpermute sh1 f = gather (Core.map f (Core.id sh1))--zipWith ::-   (Core.C array, Shape.C sh) =>-   (Exp a -> Exp b -> Exp c) ->-   array sh a -> array sh b -> array sh c-zipWith = ShapeDep.backpermute2 Shape.intersect id id--zipWith3 ::-   (Core.C array, Shape.C sh) =>-   (Exp a -> Exp b -> Exp c -> Exp d) ->-   array sh a -> array sh b -> array sh c -> array sh d-zipWith3 f a b c =-   zipWith (\ab -> uncurry f (Expr.unzip ab)) (zipWith Expr.zip a b) c--zipWith4 ::-   (Core.C array, Shape.C sh) =>-   (Exp a -> Exp b -> Exp c -> Exp d -> Exp e) ->-   array sh a -> array sh b -> array sh c -> array sh d -> array sh e-zipWith4 f a b c d =-   zipWith3 (\ab -> uncurry f (Expr.unzip ab)) (zipWith Expr.zip a b) c d---zip ::-   (Core.C array, Shape.C sh) =>-   array sh a -> array sh b -> array sh (a,b)-zip = zipWith (Expr.lift2 MultiValue.zip)--zip3 ::-   (Core.C array, Shape.C sh) =>-   array sh a -> array sh b -> array sh c -> array sh (a,b,c)-zip3 = zipWith3 (Expr.lift3 MultiValue.zip3)--zip4 ::-   (Core.C array, Shape.C sh) =>-   array sh a -> array sh b -> array sh c -> array sh d ->-   array sh (a,b,c,d)-zip4 = zipWith4 (Expr.lift4 MultiValue.zip4)
+ src/Data/Array/Knead/Symbolic.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+module Data.Array.Knead.Symbolic (+   Core.Array,+   Core.C(..),+   Exp,+   fix,+   shape,+   (Core.!),+   Core.the,+   Core.fromScalar,+   Core.fill,+   gather,+   backpermute,+   Core.backpermute2,+   Core.id,+   Core.map,+   Core.mapWithIndex,+   zipWith,+   zipWith3,+   zipWith4,+   zip,+   zip3,+   zip4,+   Core.fold1,+   Core.fold1All,+   Core.findAll,+   ) where++import qualified Data.Array.Knead.Symbolic.ShapeDependent as ShapeDep+import qualified Data.Array.Knead.Symbolic.Private as Core+import Data.Array.Knead.Symbolic.Private (Array, shape, 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.Extra.Multi.Value as MultiValue++import Data.Function.HT (Id)++import Prelude hiding (zipWith, zipWith3, zip, zip3, replicate, )+++fix :: Id (Array sh a)+fix = id++backpermute ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    MultiValue.C a) =>+   Exp sh1 ->+   (Exp ix1 -> Exp ix0) ->+   Array sh0 a ->+   Array sh1 a+backpermute sh1 f = gather (Core.map f (Core.id sh1))++zipWith ::+   (Core.C array, Shape.C sh) =>+   (Exp a -> Exp b -> Exp c) ->+   array sh a -> array sh b -> array sh c+zipWith = ShapeDep.backpermute2 Shape.intersect id id++zipWith3 ::+   (Core.C array, Shape.C sh) =>+   (Exp a -> Exp b -> Exp c -> Exp d) ->+   array sh a -> array sh b -> array sh c -> array sh d+zipWith3 f a b c =+   zipWith (\ab -> uncurry f (Expr.unzip ab)) (zipWith Expr.zip a b) c++zipWith4 ::+   (Core.C array, Shape.C sh) =>+   (Exp a -> Exp b -> Exp c -> Exp d -> Exp e) ->+   array sh a -> array sh b -> array sh c -> array sh d -> array sh e+zipWith4 f a b c d =+   zipWith3 (\ab -> uncurry f (Expr.unzip ab)) (zipWith Expr.zip a b) c d+++zip ::+   (Core.C array, Shape.C sh) =>+   array sh a -> array sh b -> array sh (a,b)+zip = zipWith (Expr.lift2 MultiValue.zip)++zip3 ::+   (Core.C array, Shape.C sh) =>+   array sh a -> array sh b -> array sh c -> array sh (a,b,c)+zip3 = zipWith3 (Expr.lift3 MultiValue.zip3)++zip4 ::+   (Core.C array, Shape.C sh) =>+   array sh a -> array sh b -> array sh c -> array sh d ->+   array sh (a,b,c,d)+zip4 = zipWith4 (Expr.lift4 MultiValue.zip4)
+ src/Data/Array/Knead/Symbolic/Fold.hs view
@@ -0,0 +1,98 @@+{- |+Reduce selected dimensions.+Alternatively you may reorder dimensions with 'ShapeDep.backpermute'+and fold once along multiple dimensions.+-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Data.Array.Knead.Symbolic.Fold (+   T,+   Cubic,+   apply,+   passAny,+   pass,+   fold,+   (Core.$:.),+   ) where++import qualified Data.Array.Knead.Symbolic.Private as Core+import Data.Array.Knead.Symbolic.Private (Array(Array), Code, Val, )++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.Shape.Cubic ((#:.), (:.)((:.)), )++import LLVM.DSL.Expression (Exp, unExp)++import qualified LLVM.Extra.Multi.Value as MultiValue+import LLVM.Extra.Multi.Value (atom, )++import qualified Type.Data.Num.Unary as Unary++import Prelude hiding (zipWith, zipWith3, zip, zip3, replicate, )+++data T sh0 sh1 a =+   forall ix0 ix1.+   (Shape.Index sh0 ~ ix0, Shape.Index sh1 ~ ix1) =>+   Cons+      (Exp sh0 -> Exp sh1)+      (forall r. Val sh0 -> (Val ix0 -> Code r a) -> (Val ix1 -> Code r a))+++apply ::+   (Core.C array, Shape.C sh0, Shape.C sh1, MultiValue.C a) =>+   T sh0 sh1 a ->+   array sh0 a ->+   array sh1 a+apply (Cons fsh reduce) =+   Core.lift1 $ \(Array sh code) ->+      Array (fsh sh) (\ix -> do sh0 <- unExp sh; reduce sh0 code ix)+++type Cubic rank0 rank1 = T (Cubic.Shape rank0) (Cubic.Shape rank1)++passAny :: Cubic rank rank a+passAny = Cons id (const id)++pass ::+   (Unary.Natural rank0, Unary.Natural rank1, MultiValue.C a) =>+   Cubic rank0 rank1 a ->+   Cubic (Unary.Succ rank0) (Unary.Succ rank1) a+pass (Cons fsh reduce) =+   Cons+      (Expr.modify (atom:.atom) $ \(sh:.s) -> fsh sh :. s)+      (\sh code ->+       Cubic.switchR $ \jx j ->+          reduce (Cubic.tail sh) (\kx -> code (kx #:. j)) jx)+++fold1CodeLinear ::+   (Unary.Natural rank, MultiValue.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Exp Index.Int ->+   (Val (Cubic.Index (Unary.Succ rank)) -> Code r a) ->+   (Val (Cubic.Index rank) -> Code r a)+fold1CodeLinear f nc code ix =+   Core.fold1Code f+      (Expr.lift1 (MultiValue.compose . Shape.ZeroBased) $ Index.decons nc)+      (\j -> code (ix #:. Index.cons j))++fold ::+   (Unary.Natural rank0, Unary.Natural rank1, MultiValue.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Cubic rank0 rank1 a ->+   Cubic (Unary.Succ rank0) rank1 a+fold f (Cons fsh reduce) =+   Cons+      (fsh . Cubic.tail)+      (\sh code jx ->+          reduce (Cubic.tail sh)+             (fold1CodeLinear f (Expr.lift0 (Cubic.head sh)) code) jx)+++instance Core.Process (T sh0 sh1 a) where
+ src/Data/Array/Knead/Symbolic/Physical.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Data.Array.Knead.Symbolic.Physical (+   Array,+   shape,+   toList,+   fromList,+   vectorFromList,+   with,+   render,+   scanl1,+   mapAccumLSimple,+   scatter,+   scatterMaybe,+   permute,+   ) where++import qualified Data.Array.Knead.Symbolic.PhysicalPrivate as Priv+import qualified Data.Array.Knead.Symbolic.Private as Sym+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.Knead.Code (getElementPtr)++import qualified LLVM.DSL.Execution as Code+import LLVM.DSL.Expression (Exp, unExp)++import qualified Data.Array.Comfort.Storable.Mutable.Unchecked as MutArray+import qualified Data.Array.Comfort.Storable.Unchecked as Array+import qualified Data.Array.Comfort.Shape as ComfortShape+import Data.Array.Comfort.Storable.Unchecked (Array(Array))++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.Maybe as Maybe++import qualified LLVM.Core as LLVM++import Foreign.Storable (Storable, )+import Foreign.ForeignPtr (withForeignPtr, mallocForeignPtrArray, )+import Foreign.Ptr (FunPtr, Ptr, )++import Control.Monad.HT (void, (<=<), )+import Control.Applicative (liftA2, (<$>), )++import Prelude2010 hiding (scanl1)+import Prelude ()+++shape :: Array sh a -> sh+shape = Array.shape++toList ::+   (Shape.C sh, Storable a) =>+   Array sh a -> IO [a]+toList = MutArray.toList <=< MutArray.unsafeThaw++fromList ::+   (Shape.C sh, Storable a) =>+   sh -> [a] -> IO (Array sh a)+fromList sh = MutArray.unsafeFreeze <=< MutArray.fromList sh++vectorFromList ::+   (Num n, Storable a) =>+   [a] -> IO (Array (ComfortShape.ZeroBased n) a)+vectorFromList xs =+   Array.mapShape (\(Shape.ZeroBased n) -> Shape.ZeroBased $ fromIntegral n) <$>+   (MutArray.unsafeFreeze =<< MutArray.vectorFromList xs)+++{- |+The symbolic array is only valid inside the enclosed action.+-}+with ::+   (Shape.C sh, Storable.C a) =>+   (Sym.Array sh a -> IO b) ->+   Array sh a -> IO b+with f (Array sh fptr) =+   withForeignPtr fptr $ \ptr ->+      f $+      Sym.Array+         (Shape.value sh)+         (\ix ->+            Storable.load =<<+               getElementPtr (Shape.value sh) (LLVM.valueOf ptr) ix)+++type Importer f = FunPtr f -> f++foreign import ccall safe "dynamic" callShaper ::+   Importer (LLVM.Ptr sh -> IO Shape.Size)++foreign import ccall safe "dynamic" callRenderer ::+   Importer (LLVM.Ptr sh -> Ptr a -> IO ())+++materialize ::+   (Shape.C sh, Marshal.C sh, Storable.C a) =>+   String ->+   Exp sh ->+   (LLVM.Value (MarshalPtr sh) ->+    LLVM.Value (Ptr a) -> LLVM.CodeGenFunction () ()) ->+   IO (Array sh a)+materialize name esh code =+   Marshal.alloca $ \lshptr -> do+      (fsh, farr) <-+         Code.compile name $+         liftA2 (,)+            (Code.createFunction callShaper "shape" $ \ptr -> do+               sh <- unExp esh+               Memory.store sh ptr+               Shape.size sh)+            (Code.createFunction callRenderer "fill" code)+      n <- fsh lshptr+      fptr <- mallocForeignPtrArray (fromIntegral n)+      withForeignPtr fptr $ farr lshptr+      sh <- Marshal.peek lshptr+      return (Array sh fptr)++render ::+   (Shape.C sh, Marshal.C sh, Storable.C a) =>+   Sym.Array sh a -> IO (Array sh a)+render (Sym.Array esh code) =+   materialize "render" esh $ \sptr ptr -> do+      let step ix p = flip Storable.storeNext p =<< code ix+      sh <- Shape.load esh sptr+      void $ Shape.loop step sh ptr++scanl1 ::+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    Storable.C a, MultiValue.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Sym.Array (sh, n) a -> IO (Array (sh, n) a)+scanl1 f (Sym.Array esh code) =+   materialize "scanl1" esh $ \sptr ptr -> do+      (sh, n) <- MultiValue.unzip <$> Shape.load esh sptr+      let step ix ptrStart =+             fmap fst $+             (\body -> Shape.loop body n (ptrStart, Maybe.nothing)) $+                   \k0 (ptr0, macc0) -> do+                a <- code $ MultiValue.zip ix k0+                acc1 <- Maybe.run macc0 (return a) (flip (Expr.unliftM2 f) a)+                ptr1 <- Storable.storeNext acc1 ptr0+                return (ptr1, Maybe.just acc1)+      void $ Shape.loop step sh ptr++mapAccumLSimple ::+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    MultiValue.C acc, Storable.C x, Storable.C y) =>+   (Exp acc -> Exp x -> Exp (acc,y)) ->+   Sym.Array sh acc -> Sym.Array (sh, n) x -> IO (Array (sh, n) y)+mapAccumLSimple f arrInit arrData =+   materialize "mapAccumLSimple" (Sym.shape arrData) $+      Priv.mapAccumLSimple f arrInit arrData++scatterMaybe ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,+    Storable.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Sym.Array sh1 a ->+   Sym.Array sh0 (Maybe (ix1, a)) -> IO (Array sh1 a)+scatterMaybe accum arrInit arrMap =+   materialize "scatterMaybe" (Sym.shape arrInit) $+      Priv.scatterMaybe accum arrInit arrMap++scatter ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,+    Storable.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Sym.Array sh1 a ->+   Sym.Array sh0 (ix1, a) -> IO (Array sh1 a)+scatter accum arrInit arrMap =+   materialize "scatter" (Sym.shape arrInit) $+      Priv.scatter accum arrInit arrMap++permute ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,+    Storable.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Sym.Array sh1 a ->+   (Exp ix0 -> Exp ix1) ->+   Sym.Array sh0 a ->+   IO (Array sh1 a)+permute accum deflt ixmap input =+   scatter accum deflt+      (Sym.mapWithIndex (Expr.lift2 MultiValue.zip . ixmap) input)
+ src/Data/Array/Knead/Symbolic/PhysicalPrivate.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Data.Array.Knead.Symbolic.PhysicalPrivate where++import qualified Data.Array.Knead.Symbolic.Private as Sym+import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Code (getElementPtr)++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.Control as C++import qualified LLVM.Core as LLVM++import Foreign.Ptr (Ptr, )++import qualified Control.Applicative.HT as App+import Control.Monad.HT (void, )+import Control.Applicative ((<$>), )++import Data.Tuple.HT (mapSnd, )++import Prelude2010+import Prelude ()++++type MarshalPtr a = LLVM.Ptr (Marshal.Struct a)++writeArray ::+   (Shape.C sh, Shape.Index sh ~ ix, Storable.C a) =>+   MultiValue.T sh ->+   (MultiValue.T ix -> LLVM.CodeGenFunction r (MultiValue.T a)) ->+   LLVM.Value (Ptr a) ->+   LLVM.CodeGenFunction r (LLVM.Value (Ptr a))+writeArray sh code ptr = do+   let clear ix p = flip Storable.storeNext p =<< code ix+   Shape.loop clear sh ptr+++mapAccumLLoop ::+   (MultiValue.C acc, Storable.C b,+    Shape.C sh, Shape.Index sh ~ ix) =>+   (MultiValue.T ix -> LLVM.CodeGenFunction r (MultiValue.T a)) ->+   (Exp acc -> Exp a -> Exp (acc, b)) ->+   MultiValue.T sh ->+   LLVM.Value (Ptr b) -> MultiValue.T acc ->+   LLVM.CodeGenFunction r (LLVM.Value (Ptr b), MultiValue.T acc)+mapAccumLLoop code f n yPtr accInit = do+   let step k0 (ptr0, acc0) = do+         x <- code k0+         (acc1,y) <- MultiValue.unzip <$> Expr.unliftM2 f acc0 x+         ptr1 <- Storable.storeNext y ptr0+         return (ptr1, acc1)+   Shape.loop step n (yPtr, accInit)++mapAccumLSimple ::+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    MultiValue.C acc,+    Storable.C x,+    Storable.C y) =>+   (Exp acc -> Exp x -> Exp (acc,y)) ->+   Sym.Array sh acc -> Sym.Array (sh, n) x ->+   LLVM.Value (MarshalPtr (sh,n)) ->+   LLVM.Value (Ptr y) ->+   LLVM.CodeGenFunction r ()+mapAccumLSimple f (Sym.Array _ initCode) (Sym.Array esh code) sptr ptr = do+   (sh, n) <- MultiValue.unzip <$> Shape.load esh sptr+   let step ix ptrStart = do+         accInit <- initCode ix+         fst <$> mapAccumLLoop (code . MultiValue.zip ix) f n ptrStart accInit+   void $ Shape.loop step sh ptr++mapAccumLSequence ::+   (Shape.C n, Marshal.C n,+    MultiValue.C acc, Storable.C final,+    Storable.C x,+    Storable.C y) =>+   (Exp acc -> Exp x -> Exp (acc,y)) ->+   (Exp acc -> Exp final) ->+   Exp acc -> Sym.Array n x ->+   LLVM.Value (Ptr final) ->+   LLVM.Value (MarshalPtr n) ->+   LLVM.Value (Ptr y) ->+   LLVM.CodeGenFunction r ()+mapAccumLSequence f final initExp (Sym.Array esh code) accPtr sptr yPtr = do+   n <- Shape.load esh sptr+   accInit <- unExp initExp+   accExit <- snd <$> mapAccumLLoop code f n yPtr accInit+   flip Storable.store accPtr =<< Expr.unliftM1 final accExit++mapAccumL ::+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    MultiValue.C acc, Storable.C final,+    Storable.C x,+    Storable.C y) =>+   (Exp acc -> Exp x -> Exp (acc,y)) ->+   (Exp acc -> Exp final) ->+   Sym.Array sh acc -> Sym.Array (sh, n) x ->+   (LLVM.Value (MarshalPtr sh), LLVM.Value (Ptr final)) ->+   (LLVM.Value (MarshalPtr (sh,n)), LLVM.Value (Ptr y)) ->+   LLVM.CodeGenFunction r ()+mapAccumL f final (Sym.Array _ initCode) (Sym.Array esh code)+      (_, accPtr) (sptr, yPtr) = do+   (sh, n) <- MultiValue.unzip <$> Shape.load esh sptr+   let step ix (accPtr0, yPtrStart) = do+         accInit <- initCode ix+         (ptrStop, accExit) <-+            mapAccumLLoop (code . MultiValue.zip ix) f n yPtrStart accInit+         accPtr1 <-+            flip Storable.storeNext accPtr0+               =<< Expr.unliftM1 final accExit+         return (accPtr1, ptrStop)+   void $ Shape.loop step sh (accPtr,yPtr)++foldOuterL ::+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    Storable.C a) =>+   (Exp a -> Exp b -> Exp a) ->+   Sym.Array sh a -> Sym.Array (n,sh) b ->+   LLVM.Value (MarshalPtr sh) ->+   LLVM.Value (Ptr a) ->+   LLVM.CodeGenFunction r ()+foldOuterL f (Sym.Array _ initCode) (Sym.Array esh code) sptr ptr = do+   sh <- Shape.load (Expr.snd esh) sptr+   n <- MultiValue.fst <$> unExp esh+   void $ writeArray sh initCode ptr++   let step k ix ptr0 = do+         b <- code $ MultiValue.zip k ix+         a0 <- Storable.load ptr0+         a1 <- Expr.unliftM2 f a0 b+         Storable.storeNext a1 ptr0+   void $ Shape.loop (\k () -> void $ Shape.loop (step k) sh ptr) n ()++{- |+We need a scalar Shape type @n@.+Scalar Shape types could be distinguished from other Shape types+by the fact that you can convert any Index into a Shape.+-}+mapFilter ::+   (Shape.Sequence n, Marshal.C n,+    Storable.C b) =>+   (Exp a -> Exp b) ->+   (Exp a -> Exp Bool) ->+   Sym.Array n a ->+   LLVM.Value (MarshalPtr n) ->+   LLVM.Value (Ptr b) ->+   LLVM.CodeGenFunction r (MultiValue.T n)+mapFilter f p (Sym.Array esh code) sptr ptr = do+   n <- Shape.load esh sptr+   let step ix (dstPtr,dstIx) = do+         a <- code ix+         MultiValue.Cons c <- Expr.unliftM1 p a+         C.ifThen c (dstPtr,dstIx)+            (App.lift2 (,)+               (flip Storable.storeNext dstPtr =<< Expr.unliftM1 f a)+               (MultiValue.inc dstIx))+   Shape.sequenceShapeFromIndex . snd+      =<< Shape.loop step n (ptr, MultiValue.zero)++filterOuter ::+   (Shape.Sequence n, Marshal.C n,+    Shape.C sh, Marshal.C sh,+    Storable.C a) =>+   Sym.Array n Bool ->+   Sym.Array (n,sh) a ->+   LLVM.Value (MarshalPtr (n,sh)) ->+   LLVM.Value (Ptr a) ->+   LLVM.CodeGenFunction r (MultiValue.T (n,sh))+filterOuter (Sym.Array _eish selectCode) (Sym.Array esh code) sptr ptr = do+   (n,sh) <- MultiValue.unzip <$> Shape.load esh sptr+   let step k (dstPtr0,dstK) = do+         MultiValue.Cons c <- selectCode k+         C.ifThen c (dstPtr0,dstK)+            (do+               dstPtr1 <- writeArray sh (code . MultiValue.zip k) dstPtr0+               (,) dstPtr1 <$> MultiValue.inc dstK)+   finalN <-+      Shape.sequenceShapeFromIndex . snd+         =<< Shape.loop step n (ptr, MultiValue.zero)+   return $ MultiValue.zip finalN sh+++scatterMaybe ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    Marshal.C sh1,+    Storable.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Sym.Array sh1 a -> Sym.Array sh0 (Maybe (ix1, a)) ->+   LLVM.Value (MarshalPtr sh1) ->+   LLVM.Value (Ptr a) ->+   LLVM.CodeGenFunction r ()+scatterMaybe accum (Sym.Array esh codeInit) (Sym.Array eish codeMap)+      sptr ptr = do++   sh <- Shape.load esh sptr+   void $ writeArray sh codeInit ptr++   ish <- unExp eish+   let fill ix () = do+         (MultiValue.Cons c, (jx, a)) <-+            mapSnd MultiValue.unzip . MultiValue.splitMaybe <$> codeMap ix+         C.ifThen c () $ do+            p <- getElementPtr sh ptr jx+            flip Storable.store p+               =<< Expr.unliftM2 (flip accum) a+               =<< Storable.load p+   Shape.loop fill ish ()++scatter ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    Marshal.C sh1,+    Storable.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Sym.Array sh1 a ->+   Sym.Array sh0 (Shape.Index sh1, a) ->+   LLVM.Value (MarshalPtr sh1) ->+   LLVM.Value (Ptr a) ->+   LLVM.CodeGenFunction r ()+scatter accum (Sym.Array esh codeInit) (Sym.Array eish codeMap) sptr ptr = do+   sh <- Shape.load esh sptr+   void $ writeArray sh codeInit ptr++   ish <- unExp eish+   let fill ix () = do+         (jx, a) <- MultiValue.unzip <$> codeMap ix+         p <- getElementPtr sh ptr jx+         flip Storable.store p+            =<< Expr.unliftM2 (flip accum) a+            =<< Storable.load p+   Shape.loop fill ish ()++addDimension ::+   (Shape.C n, Marshal.C n, Shape.Index n ~ k,+    Shape.C sh, Marshal.C sh,+    Storable.C b) =>+   Exp n ->+   (Exp k -> Exp a -> Exp b) ->+   Sym.Array sh a ->+   LLVM.Value (MarshalPtr (sh,n)) ->+   LLVM.Value (Ptr b) ->+   LLVM.CodeGenFunction r ()+addDimension en select (Sym.Array esh code) sptr ptr = do+   (sh,n) <- MultiValue.unzip <$> Shape.load (Expr.zip esh en) sptr++   let fill ix ptr0 = do+         a <- code ix+         writeArray n (\k -> Expr.unliftM2 select k a) ptr0+   void $ Shape.loop fill sh ptr
+ src/Data/Array/Knead/Symbolic/Private.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Data.Array.Knead.Symbolic.Private where++import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Knead.Expression as Expr++import LLVM.DSL.Expression (Exp(Exp))++import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Iterator as Iter+import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Core as LLVM++import qualified Control.Category as Cat+import qualified Control.Monad.HT as Monad+import Control.Monad ((<=<), )++import Prelude hiding (id, map, zipWith, replicate, )+++type Val = MultiValue.T+type Code r a = LLVM.CodeGenFunction r (Val a)++data Array sh a =+   Array (Exp sh) (forall r. Val (Shape.Index sh) -> Code r a)++shape :: Array sh a -> Exp sh+shape (Array sh _) = sh++(!) ::+   (Shape.C sh,  Shape.Index sh  ~ ix) =>+   Array sh a -> Exp ix -> Exp a+(!) (Array _ code) (Exp ix) = Exp (code =<< ix)++the :: (Shape.Scalar sh) => Array sh a -> Exp a+the (Array z code) = Exp (code $ Shape.zeroIndex z)++fromScalar :: (Shape.Scalar sh) => Exp a -> Array sh a+fromScalar = fill Shape.scalar+++fill :: Exp sh -> Exp a -> Array sh a+fill sh (Exp code) = Array sh (\_z -> code)+++{- |+This class allows to implement functions without parameters+for both simple and parameterized arrays.+-}+class C array where+   lift0 :: Array sh a -> array sh a+   lift1 :: (Array sha a -> Array shb b) -> array sha a -> array shb b+   lift2 ::+      (Array sha a -> Array shb b -> Array shc c) ->+      array sha a -> array shb b -> array shc c++instance C Array where+   lift0 = Cat.id+   lift1 = Cat.id+   lift2 = Cat.id+++gather ::+   (C array,+    Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    MultiValue.C a) =>+   array sh1 ix0 ->+   array sh0 a ->+   array sh1 a+gather =+   lift2 $ \(Array sh1 f) (Array _sh0 code) ->+      Array sh1 (code <=< f)++backpermute2 ::+   (C array,+    Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    Shape.C sh,  Shape.Index sh  ~ ix) =>+   Exp sh ->+   (Exp ix -> Exp ix0) ->+   (Exp ix -> Exp ix1) ->+   (Exp a -> Exp b -> Exp c) ->+   array sh0 a -> array sh1 b -> array sh c+backpermute2 sh projectIndex0 projectIndex1 f =+   lift2 $ \(Array _sha codeA) (Array _shb codeB) ->+      Array sh+         (\ix ->+            Monad.liftJoin2 (Expr.unliftM2 f)+               (codeA =<< Expr.unliftM1 projectIndex0 ix)+               (codeB =<< Expr.unliftM1 projectIndex1 ix))+++id ::+   (C array, Shape.C sh, Shape.Index sh ~ ix) =>+   Exp sh -> array sh ix+id sh = lift0 $ Array sh return++map ::+   (C array, Shape.C sh) =>+   (Exp a -> Exp b) ->+   array sh a -> array sh b+map f =+   lift1 $ \(Array sh code) ->+      Array sh (Expr.unliftM1 f <=< code)++mapWithIndex ::+   (C array, Shape.C sh, Shape.Index sh ~ ix) =>+   (Exp ix -> Exp a -> Exp b) ->+   array sh a -> array sh b+mapWithIndex f =+   lift1 $ \(Array sh code) ->+      Array sh (\ix -> Expr.unliftM2 f ix =<< code ix)+++fold1Code ::+   (Shape.C sh, Shape.Index sh ~ ix, MultiValue.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Exp sh ->+   (Val ix -> Code r a) ->+   Code r a+fold1Code f (Exp nc) code = do+   n <- nc+   fmap Maybe.fromJust $+      Shape.loop+         (\i0 macc0 -> do+            a <- code i0+            acc1 <- Maybe.run macc0 (return a) (flip (Expr.unliftM2 f) a)+            return $ Maybe.just acc1)+         n Maybe.nothing++fold1 ::+   (C array, Shape.C sh0, Shape.C sh1, MultiValue.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   array (sh0, sh1) a -> array sh0 a+fold1 f =+   lift1 $ \(Array shs code) ->+      case Expr.unzip shs of+         (sh, s) -> Array sh $ fold1Code f s . MultiValue.curry code+++fold1All ::+   (Shape.C sh, MultiValue.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Array sh a -> Exp a+fold1All f (Array sh code) = Exp (fold1Code f sh code)+++findAllCode ::+   (Shape.C sh, Shape.Index sh ~ ix, MultiValue.C a) =>+   (Exp a -> Exp Bool) ->+   Exp sh ->+   (Val ix -> Code r a) ->+   Code r (Maybe a)+findAllCode p (Exp sh) code = do+   n <- sh+   finalFound <-+      Iter.mapWhileState_+         (\a _found -> do+            MultiValue.Cons b <- Expr.unliftM1 p a+            notb <- LLVM.inv b+            return (notb, Maybe.fromBool b a))+         (Iter.mapM code $ Shape.iterator n)+         Maybe.nothing+   Maybe.run finalFound+      (return MultiValue.nothing)+      (return . MultiValue.just)++{- |+In principle this can be implemented using fold1All+but it has a short-cut semantics.+@All@ means that it scans all dimensions+but it does not mean that it finds all occurrences.+If you want to get the index of the found element,+please decorate the array elements with their indices before calling 'findAll'.+-}+findAll ::+   (Shape.C sh, MultiValue.C a) =>+   (Exp a -> Exp Bool) ->+   Array sh a -> Exp (Maybe a)+findAll p (Array sh code) = Exp (findAllCode p sh code)+++class Process proc where+++infixl 3 $:.++{- |+Use this for combining several dimension manipulators.+E.g.++> apply (passAny $:. pick 3 $:. pass $:. replicate 10) array++The constraint @(Process proc0, Process proc1)@ is a bit weak.+We like to enforce that the type constructor like @Slice.T@+is the same in @proc0@ and @proc1@, and only the parameters differ.+Currently this coherence is achieved,+because we only provide functions of type @proc0 -> proc1@ with this condition.+-}+($:.) :: (Process proc0, Process proc1) => proc0 -> (proc0 -> proc1) -> proc1+($:.) = flip ($)
+ src/Data/Array/Knead/Symbolic/Render.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE TypeFamilies #-}+{- |+Simplify running the @render@ function by handling passing of parameters.+-}+module Data.Array.Knead.Symbolic.Render (+   run,+   MarshalExp(..),+   MapFilter(..),+   FilterOuter(..),+   Scatter(..),+   ScatterMaybe(..),+   MapAccumLSimple(..),+   MapAccumLSequence(..),+   MapAccumL(..),+   FoldOuterL(..),+   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.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+         (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.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 ()++++class C f where+   type Plain f+   build :: Sym.Hull p f -> IO (p -> 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++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++instance+   (Shape.Sequence n, Marshal.C n,+    Shape.C sh, Marshal.C sh,+    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++instance+   (Shape.C sh0, Marshal.C sh0,+    Shape.C sh1, Marshal.C sh1,+    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++instance+   (Shape.C sh0, Marshal.C sh0,+    Shape.C sh1, Marshal.C sh1,+    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++instance+   (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) =>+      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++instance+   (Shape.C n, Marshal.C n,+    MultiValue.C acc,+    Storable.C final, MultiValue.C final,+    Storable.C a, MultiValue.C a,+    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++instance+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    MultiValue.C acc,+    Storable.C final, MultiValue.C final,+    Storable.C a, MultiValue.C a,+    Storable.C b, MultiValue.C b) =>+      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++instance+   (Shape.C n, Marshal.C n,+    Shape.C sh, Marshal.C sh,+    Storable.C a, MultiValue.C a,+    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++instance+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    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+++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++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)++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)+++class Argument arg where+   type PlainArg arg+   buildArg :: Param.T p (PlainArg arg) -> Sym.Hull p arg++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++instance (Marshal.C a) => Argument (Exp a) where+   type PlainArg (Exp a) = a+   buildArg = Sym.expHull . Sym.expParam++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)++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++++_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)
+ src/Data/Array/Knead/Symbolic/ShapeDependent.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Data.Array.Knead.Symbolic.ShapeDependent where++import qualified Data.Array.Knead.Symbolic.Private as Core+import Data.Array.Knead.Symbolic.Private (Array(Array), )++import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Expression (Exp, )++import qualified Control.Monad.HT as Monad+import Control.Monad ((<=<), )+++shape :: (Core.C array, Shape.C sh, Shape.Scalar z) => array sh a -> array z sh+shape = Core.lift1 $ Core.fromScalar . Core.shape++backpermute ::+   (Core.C array,+    Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1) =>+   (Exp sh0 -> Exp sh1) ->+   (Exp ix1 -> Exp ix0) ->+   array sh0 a ->+   array sh1 a+backpermute createShape projectIndex =+   Core.lift1 $ \(Array sh code) ->+      Array (createShape sh)+         (code <=< Expr.unliftM1 projectIndex)++{- |+This is between 'backpermute' and 'backpermute2'.+You can access the shapes of two arrays,+but only the content of one of them.+This is necessary if the second array contributes only a virtual dimension.+-}+backpermuteExtra ::+   (Core.C array,+    Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    Shape.C sh,  Shape.Index sh  ~ ix) =>+   (Exp sh0 -> Exp sh1 -> Exp sh) ->+   (Exp ix -> Exp ix0) ->+   array sh0 a -> array sh1 b -> array sh a+backpermuteExtra newShape projectIndex =+   Core.lift2 $ \(Array sh0 code) (Array sh1 _code) ->+      Array (newShape sh0 sh1)+         (\ix -> code =<< Expr.unliftM1 projectIndex ix)++backpermute2 ::+   (Core.C array,+    Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    Shape.C sh,  Shape.Index sh  ~ ix) =>+   (Exp sh0 -> Exp sh1 -> Exp sh) ->+   (Exp ix -> Exp ix0) ->+   (Exp ix -> Exp ix1) ->+   (Exp a -> Exp b -> Exp c) ->+   array sh0 a -> array sh1 b -> array sh c+backpermute2 combineShape projectIndex0 projectIndex1 f =+   Core.lift2 $ \(Array sha codeA) (Array shb codeB) ->+      Array (combineShape sha shb)+         (\ix ->+            Monad.liftJoin2 (Expr.unliftM2 f)+               (codeA =<< Expr.unliftM1 projectIndex0 ix)+               (codeB =<< Expr.unliftM1 projectIndex1 ix))++fill ::+   (Core.C array) =>+   (Exp sh0 -> Exp sh1) -> Exp b ->+   array sh0 a -> array sh1 b+fill fsh a =+   Core.lift1 $ \arr ->+      Core.fill (fsh $ Core.shape arr) a
+ src/Data/Array/Knead/Symbolic/Slice.hs view
@@ -0,0 +1,198 @@+{- |+Generate and apply index maps.+This unifies the @replicate@ and @slice@ functions of the @accelerate@ package.+However the structure of slicing and replicating cannot depend on parameters.+If you need that, you must use 'ShapeDep.backpermute' and friends.+-}+{-+Some notes on the design choice:++Instead of the shallow embedding implemented by the 'T' type,+we could maintain a symbolic representation of the Slice and Replicate pattern,+like the accelerate package does.+We actually used that representation in former versions.+It has however some drawbacks:++* We need additional type functions that map from the pattern+  to the source and the target shape and we need a proof,+  that the images of these type functions are actually shapes.+  This worked already, but was rather cumbersome.++* We need a way to store and pass this pattern through the Parameter handler.+  This yields new problems:+  We need a wrapper type for wrapping Index, Shape, Slice, Replicate, Fold patterns.+  Then the question is whether we use one Wrap type with a phantom parameter+  or whether we define a Wrap type for every pattern type.+  That is, the options are to write either++  > Wrap Shape (Z:.Int:.Int)++  or++  > Shape (Z:.Int:.Int)++  The first one seems to save us many duplicate instances of+  Storable, MultiValue etc.+  and it allows us easily to reuse the (:.) for all kinds of patterns.+  However, we need a way to restrict the element type of the (:.)-list elements.+  We can define that using variable ConstraintKinds,+  but e.g. we are not able to add a Storable superclass constraint+  to the instance Storable (Wrap constr).+  That is, we are left with the second option+  and had to define a lot of similar Storable, MultiValue instances.+-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Data.Array.Knead.Symbolic.Slice (+   T,+   Cubic,+   apply,+   passAny,+   pass,+   pick,+   pickFst,+   pickSnd,+   extrude,+   extrudeFst,+   extrudeSnd,+   transpose,+   (Core.$:.),++   id,+   first,+   second,+   compose,+   ) where++import qualified Data.Array.Knead.Symbolic.ShapeDependent as ShapeDep+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.Shape.Cubic ((#:.), (:.)((:.)), )+import Data.Array.Knead.Expression (Exp, )++import qualified LLVM.Extra.Multi.Value as MultiValue+import LLVM.Extra.Multi.Value (atom, )++import qualified Type.Data.Num.Unary as Unary++import qualified Prelude as P+import Prelude hiding (id, zipWith, zipWith3, zip, zip3, replicate, )++++{-+This data type is almost identical to Core.Array.+The only difference is,+that the shape @sh1@ in T can depend on another shape @sh0@.+-}+data T sh0 sh1 =+   forall ix0 ix1.+   (Shape.Index sh0 ~ ix0, Shape.Index sh1 ~ ix1) =>+   Cons+      (Exp sh0 -> Exp sh1)+      (Exp ix1 -> Exp ix0)++{- |+This is essentially a 'ShapeDep.backpermute'.+-}+apply ::+   (Core.C array, Shape.C sh0, Shape.C sh1, MultiValue.C a) =>+   T sh0 sh1 ->+   array sh0 a ->+   array sh1 a+apply (Cons fsh fix) =+   ShapeDep.backpermute fsh fix+++pickFst :: Exp (Shape.Index n) -> T (n,sh) sh+pickFst i = Cons Expr.snd (Expr.zip i)++pickSnd :: Exp (Shape.Index n) -> T (sh,n) sh+pickSnd i = Cons Expr.fst (flip Expr.zip i)++{- |+Extrusion has the potential to do duplicate work.+Only use it to add dimensions of size 1, e.g. numeric 1 or unit @()@+or to duplicate slices of physical arrays.+-}+extrudeFst :: Exp n -> T sh (n,sh)+extrudeFst n = Cons (Expr.zip n) Expr.snd++extrudeSnd :: Exp n -> T sh (sh,n)+extrudeSnd n = Cons (flip Expr.zip n) Expr.fst++transpose :: T (sh0,sh1) (sh1,sh0)+transpose = Cons Expr.swap Expr.swap+++-- Arrow combinators++id :: T sh sh+id = Cons P.id P.id++first :: T sh0 sh1 -> T (sh0,sh) (sh1,sh)+first (Cons fsh fix) = Cons (Expr.mapFst fsh) (Expr.mapFst fix)++second :: T sh0 sh1 -> T (sh,sh0) (sh,sh1)+second (Cons fsh fix) = Cons (Expr.mapSnd fsh) (Expr.mapSnd fix)++infixr 1 `compose`++compose :: T sh0 sh1 -> T sh1 sh2 -> T sh0 sh2+compose (Cons fshA fixA) (Cons fshB fixB) = Cons (fshB . fshA) (fixA . fixB)+++type Cubic rank0 rank1 = T (Cubic.Shape rank0) (Cubic.Shape rank1)++{- |+Like @Any@ in @accelerate@.+-}+passAny :: Cubic rank rank+passAny = Cons P.id P.id++{- |+Like @All@ in @accelerate@.+-}+pass ::+   (Unary.Natural rank0, Unary.Natural rank1) =>+   Cubic rank0 rank1 ->+   Cubic (Unary.Succ rank0) (Unary.Succ rank1)+pass (Cons fsh fix) =+   Cons+      (Expr.modify (atom:.atom) $ \(sh:.s) -> fsh sh :. s)+      (Expr.modify (atom:.atom) $ \(ix:.i) -> fix ix :. i)++{- |+Like @Int@ in @accelerate/slice@.+-}+pick ::+   (Unary.Natural rank0, Unary.Natural rank1) =>+   Exp Index.Int ->+   Cubic rank0 rank1 ->+   Cubic (Unary.Succ rank0) rank1+pick i (Cons fsh fix) =+   Cons+      (fsh . Cubic.tail)+      (\ix -> fix ix #:. i)++{- |+Like @Int@ in @accelerate/replicate@.+-}+extrude ::+   (Unary.Natural rank0, Unary.Natural rank1) =>+   Exp Index.Int ->+   Cubic rank0 rank1 ->+   Cubic rank0 (Unary.Succ rank1)+extrude n (Cons fsh fix) =+   Cons+      (\sh -> fsh sh #:. n)+      (fix . Cubic.tail)+++instance Core.Process (T sh0 sh1) where
test/Test/Array.hs view
@@ -1,16 +1,16 @@ module Test.Array where -import qualified Data.Array.Knead.Parameterized.Render as Render-import qualified Data.Array.Knead.Simple.Symbolic as Symb-import qualified Data.Array.Knead.Simple.Slice as Slice+import qualified Data.Array.Knead.Symbolic.Render as Render+import qualified Data.Array.Knead.Symbolic as Symb+import qualified Data.Array.Knead.Symbolic.Slice as Slice import qualified Data.Array.Knead.Expression as Expr import qualified Data.Array.Knead.Shape as Shape import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as ComfortShape import Data.Array.Comfort.Storable (Array) -import qualified LLVM.Extra.Storable as Storable-import qualified LLVM.Extra.Marshal as Marshal+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.Core as LLVM@@ -71,8 +71,8 @@ columnPred x y  =  Array.toList y == foldl1 (zipWith (+)) (getRows x)  run ::-   (Shape.C sh0, Marshal.MV sh0, Show sh0,-    Shape.C sh1, Marshal.MV sh1, Show sh1,+   (Shape.C sh0, Marshal.C sh0, Show sh0,+    Shape.C sh1, Marshal.C sh1, Show sh1,     Show a, Num a, Eq a, Storable.C a) =>    QC.Gen (Array sh0 a) ->    (Symb.Array sh0 a -> Symb.Array sh1 a) ->