packages feed

knead 0.2.3 → 1.0.2

raw patch · 39 files changed

Files

+ Makefile view
@@ -0,0 +1,5 @@+run-test:+	runhaskell Setup configure --user --enable-tests+	runhaskell Setup build+	runhaskell Setup haddock+	./dist/build/knead-test/knead-test
knead.cabal view
@@ -1,12 +1,12 @@ Name:             knead-Version:          0.2.3+Version:          1.0.2 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 array processing using LLVM JIT+Synopsis:         Repa-like array processing using LLVM JIT Description:   This library processes arrays like @Repa@ and @Accelerate@,   but it uses the just-in-time compiler of @LLVM@@@ -15,7 +15,8 @@   that can be run without a GPU.   You do not need to care about inlining and strictness annotations,   because the LLVM code is by default inlined and strict.-  The package is the basis for an LLVM backend for the @Accelerate@ framework.+  The package is intended as the basis+  for an LLVM backend for the @Accelerate@ framework.   .   Highlights:   .@@ -42,50 +43,77 @@   .   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, GHC==8.0.1-Cabal-Version:    >=1.6+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.2.3+  Tag:         1.0.2   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-extra >=0.7.3 && <0.8,-    llvm-tf >=3.1 && <3.2,+    llvm-dsl >=0.2 && <0.3,+    llvm-extra >=0.12.1 && <0.14,+    llvm-tf >=9.0 && <21.1,     tfp >=1.0 && <1.1,-    storable-tuple >=0.0 && <0.1,-    storable-record >=0.0.3 && <0.1,-    transformers >=0.3 && <0.6,-    utility-ht >=0.0.1 && <0.1,+    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.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:-    Data.Array.Knead.Index.Linear.Int-    Data.Array.Knead.Index.Linear-    Data.Array.Knead.Index.Nested.Shape+    Data.Array.Knead.Shape+    Data.Array.Knead.Shape.Cubic+    Data.Array.Knead.Shape.Cubic.Int     Data.Array.Knead.Expression-    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.Parameterized.Private-    Data.Array.Knead.Parameterized.PhysicalHull+    Data.Array.Knead.Symbolic.RenderAlt+    Data.Array.Knead.Symbolic.Render.Basic+    Data.Array.Knead.Symbolic.Render.Argument+    Data.Array.Knead.Symbolic.Private+    Data.Array.Knead.Symbolic.PhysicalParametric+    Data.Array.Knead.Symbolic.PhysicalPrivate     Data.Array.Knead.Code+    Data.Array.Knead.Shape.Orphan++Test-Suite knead-test+  Type: exitcode-stdio-1.0+  Build-Depends:+    QuickCheck >=2 && <3,+    knead,+    comfort-array,+    llvm-extra,+    llvm-tf,+    tfp,+    utility-ht,+    base+  Default-Language: Haskell98+  GHC-Options: -Wall+  Hs-Source-Dirs: test+  Main-Is: Main.hs+  Other-Modules:+    Test.Array
src/Data/Array/Knead/Code.hs view
@@ -1,56 +1,24 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Code where -import qualified Data.Array.Knead.Index.Nested.Shape as Shape+import qualified Data.Array.Knead.Shape as Shape -import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Nice.Value.Storable as Storable+import qualified LLVM.Extra.Nice.Value as NiceValue -import qualified LLVM.ExecutionEngine as EE-import qualified LLVM.Util.Optimize as Opt import qualified LLVM.Core as LLVM -import Foreign.Ptr (Ptr, FunPtr, )--import Control.Monad (void, liftM2, when, )-import Control.Applicative ((<$>), )+import Foreign.Ptr (Ptr) -import Data.Functor.Compose (Compose(Compose))+import Prelude2010+import Prelude ()   getElementPtr ::-   (Shape.C sh, Shape.Index sh ~ ix) =>-   MultiValue.T sh -> LLVM.Value (Ptr a) ->-   MultiValue.T ix ->+   (Shape.C sh, Shape.Index sh ~ ix, Storable.C a) =>+   NiceValue.T sh -> LLVM.Value (Ptr a) ->+   NiceValue.T ix ->    LLVM.CodeGenFunction r (LLVM.Value (Ptr a))-getElementPtr sh ptr ix = do-   n <- Shape.flattenIndex sh ix-   LLVM.getElementPtr ptr (n, ())---compile :: String -> Exec funcs -> IO funcs-compile name (Compose bld) = do-   LLVM.initializeNativeTarget-   m <- LLVM.newModule-   (funcs, mappings) <--      LLVM.defineModule m $ do-         LLVM.setTarget LLVM.hostTriple-         liftM2 (,) bld LLVM.getGlobalMappings-   LLVM.writeBitcodeToFile (name ++ ".bc") m-   when False $ do-      void $ Opt.optimizeModule 3 m-      LLVM.writeBitcodeToFile (name ++ "-opt.bc") m-   EE.runEngineAccessWithModule m $-      EE.addGlobalMappings mappings >> funcs---type Exec = Compose LLVM.CodeGenModule EE.EngineAccess-type Importer f = FunPtr f -> f--createFunction ::-   (EE.ExecutionFunction f, LLVM.FunctionArgs f) =>-   Importer f -> String -> LLVM.FunctionCodeGen f -> Exec f-createFunction importer name f =-   Compose $-      EE.getExecutionFunction importer-      <$>-      LLVM.createNamedFunction LLVM.ExternalLinkage name f+getElementPtr sh ptr ix =+   flip Storable.advancePtr ptr =<< LLVM.bitcast =<< Shape.offset sh ix
src/Data/Array/Knead/Expression.hs view
@@ -1,463 +1,91 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-module Data.Array.Knead.Expression where--import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Monad as LMonad-import qualified LLVM.Core as LLVM-import LLVM.Extra.Multi.Value (PatternTuple, Decomposed, Atom, atom, )--import qualified Control.Monad as Monad--import qualified Data.Tuple.HT as TupleHT-import qualified Data.Tuple as Tuple-import Data.Complex (Complex((:+)))--import Prelude-   hiding (fst, snd, min, max, zip, unzip, zip3, unzip3,-           curry, uncurry, pi, maybe)---newtype Exp a = Exp {unExp :: forall r. LLVM.CodeGenFunction r (MultiValue.T a)}---class Value val where-   lift0 :: MultiValue.T a -> val a-   lift1 ::-      (MultiValue.T a -> MultiValue.T b) ->-      val a -> val b-   lift2 ::-      (MultiValue.T a -> MultiValue.T b -> MultiValue.T c) ->-      val a -> val b -> val c-   lift3 ::-      (MultiValue.T a -> MultiValue.T b -> MultiValue.T c -> MultiValue.T d) ->-      val a -> val b -> val c -> val d-   lift4 ::-      (MultiValue.T a -> MultiValue.T b -> MultiValue.T c -> MultiValue.T d -> MultiValue.T e) ->-      val a -> val b -> val c -> val d -> val e--instance Value MultiValue.T where-   lift0 = id-   lift1 = id-   lift2 = id-   lift3 = id-   lift4 = id--instance Value Exp where-   lift0 a = Exp (return a)-   lift1 f (Exp a) = Exp (Monad.liftM f a)-   lift2 f (Exp a) (Exp b) = Exp (Monad.liftM2 f a b)-   lift3 f (Exp a) (Exp b) (Exp c) = Exp (Monad.liftM3 f a b c)-   lift4 f (Exp a) (Exp b) (Exp c) (Exp d) = Exp (Monad.liftM4 f a b c d)---liftM ::-   (forall r.-    MultiValue.T a ->-    LLVM.CodeGenFunction r (MultiValue.T b)) ->-   (Exp a -> Exp b)-liftM f (Exp a) = Exp (f =<< a)--liftM2 ::-   (forall r.-    MultiValue.T a -> MultiValue.T b ->-    LLVM.CodeGenFunction r (MultiValue.T c)) ->-   (Exp a -> Exp b -> Exp c)-liftM2 f (Exp a) (Exp b) = Exp (LMonad.liftR2 f a b)--liftM3 ::-   (forall r.-    MultiValue.T a -> MultiValue.T b -> MultiValue.T c ->-    LLVM.CodeGenFunction r (MultiValue.T d)) ->-   (Exp a -> Exp b -> Exp c -> Exp d)-liftM3 f (Exp a) (Exp b) (Exp c) = Exp (LMonad.liftR3 f a b c)---unliftM1 ::-   (Exp a -> Exp b) ->-   MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T b)-unliftM1 f ix = unExp (f (lift0 ix))--unliftM2 ::-   (Exp a -> Exp b -> Exp c) ->-   MultiValue.T a -> MultiValue.T b ->-   LLVM.CodeGenFunction r (MultiValue.T c)-unliftM2 f ix jx = unExp (f (lift0 ix) (lift0 jx))--unliftM3 ::-   (Exp a -> Exp b -> Exp c -> Exp d) ->-   MultiValue.T a -> MultiValue.T b -> MultiValue.T c ->-   LLVM.CodeGenFunction r (MultiValue.T d)-unliftM3 f ix jx kx = unExp (f (lift0 ix) (lift0 jx) (lift0 kx))----min :: (MultiValue.Real a) => Exp a -> Exp a -> Exp a-min = liftM2 A.min--max :: (MultiValue.Real a) => Exp a -> Exp a -> Exp a-max = liftM2 A.max---zip :: (Value val) => val a -> val b -> val (a, b)-zip = lift2 MultiValue.zip--zip3 :: (Value val) => val a -> val b -> val c -> val (a, b, c)-zip3 = lift3 MultiValue.zip3--zip4 :: (Value val) => val a -> val b -> val c -> val d -> val (a, b, c, d)-zip4 = lift4 MultiValue.zip4--unzip :: (Value val) => val (a, b) -> (val a, val b)-unzip ab =-   (lift1 MultiValue.fst ab, lift1 MultiValue.snd ab)--unzip3 :: (Value val) => val (a, b, c) -> (val a, val b, val c)-unzip3 abc =-   (lift1 MultiValue.fst3 abc,-    lift1 MultiValue.snd3 abc,-    lift1 MultiValue.thd3 abc)--unzip4 :: (Value val) => val (a, b, c, d) -> (val a, val b, val c, val d)-unzip4 abcd =-   (lift1 (\(MultiValue.Cons (a,_,_,_)) -> MultiValue.Cons a) abcd,-    lift1 (\(MultiValue.Cons (_,b,_,_)) -> MultiValue.Cons b) abcd,-    lift1 (\(MultiValue.Cons (_,_,c,_)) -> MultiValue.Cons c) abcd,-    lift1 (\(MultiValue.Cons (_,_,_,d)) -> MultiValue.Cons d) abcd)---fst :: (Value val) => val (a, b) -> val a-fst = lift1 MultiValue.fst--snd :: (Value val) => val (a, b) -> val b-snd = lift1 MultiValue.snd--mapFst :: (Exp a -> Exp b) -> Exp (a, c) -> Exp (b, c)-mapFst f = modify (atom, atom) $ TupleHT.mapFst f--mapSnd :: (Exp b -> Exp c) -> Exp (a, b) -> Exp (a, c)-mapSnd f = modify (atom, atom) $ TupleHT.mapSnd f--swap :: (Value val) => val (a, b) -> val (b, a)-swap = lift1 MultiValue.swap--curry :: (Exp (a,b) -> c) -> (Exp a -> Exp b -> c)-curry f = Tuple.curry (f . Tuple.uncurry zip)--uncurry :: (Exp a -> Exp b -> c) -> (Exp (a,b) -> c)-uncurry f = Tuple.uncurry f . unzip---fst3 :: (Value val) => val (a,b,c) -> val a-fst3 = lift1 MultiValue.fst3--snd3 :: (Value val) => val (a,b,c) -> val b-snd3 = lift1 MultiValue.snd3--thd3 :: (Value val) => val (a,b,c) -> val c-thd3 = lift1 MultiValue.thd3--mapFst3 :: (Exp a0 -> Exp a1) -> Exp (a0,b,c) -> Exp (a1,b,c)-mapFst3 f = modify (atom, atom, atom) $ TupleHT.mapFst3 f--mapSnd3 :: (Exp b0 -> Exp b1) -> Exp (a,b0,c) -> Exp (a,b1,c)-mapSnd3 f = modify (atom, atom, atom) $ TupleHT.mapSnd3 f--mapThd3 :: (Exp c0 -> Exp c1) -> Exp (a,b,c0) -> Exp (a,b,c1)-mapThd3 f = modify (atom, atom, atom) $ TupleHT.mapThd3 f---modifyMultiValue ::-   (Value val,-    MultiValue.Compose a,-    MultiValue.Decompose pattern,-    MultiValue.PatternTuple pattern ~ tuple) =>-   pattern ->-   (Decomposed MultiValue.T pattern -> a) ->-   val tuple -> val (MultiValue.Composed a)-modifyMultiValue p f = lift1 $ MultiValue.modify p f--modifyMultiValue2 ::-   (Value val,-    MultiValue.Compose a,-    MultiValue.Decompose patternA,-    MultiValue.Decompose patternB,-    MultiValue.PatternTuple patternA ~ tupleA,-    MultiValue.PatternTuple patternB ~ tupleB) =>-   patternA ->-   patternB ->-   (Decomposed MultiValue.T patternA ->-    Decomposed MultiValue.T patternB -> a) ->-   val tupleA -> val tupleB -> val (MultiValue.Composed a)-modifyMultiValue2 pa pb f = lift2 $ MultiValue.modify2 pa pb f--modifyMultiValueM ::-   (MultiValue.Compose a,-    MultiValue.Decompose pattern,-    MultiValue.PatternTuple pattern ~ tuple) =>-   pattern ->-   (forall r.-    Decomposed MultiValue.T pattern ->-    LLVM.CodeGenFunction r a) ->-   Exp tuple -> Exp (MultiValue.Composed a)-modifyMultiValueM p f = liftM (MultiValue.modifyF p f)--modifyMultiValueM2 ::-   (MultiValue.Compose a,-    MultiValue.Decompose patternA,-    MultiValue.Decompose patternB,-    MultiValue.PatternTuple patternA ~ tupleA,-    MultiValue.PatternTuple patternB ~ tupleB) =>-   patternA ->-   patternB ->-   (forall r.-    Decomposed MultiValue.T patternA ->-    Decomposed MultiValue.T patternB ->-    LLVM.CodeGenFunction r a) ->-   Exp tupleA -> Exp tupleB -> Exp (MultiValue.Composed a)-modifyMultiValueM2 pa pb f = liftM2 (MultiValue.modifyF2 pa pb f)---class Compose multituple where-   type Composed multituple-   {- |-   A nested 'zip'.-   -}-   compose :: multituple -> Exp (Composed multituple)--class-   (Composed (Decomposed Exp pattern) ~ PatternTuple pattern) =>-      Decompose pattern where-   {- |-   Analogous to 'MultiValue.decompose'.-   -}-   decompose :: pattern -> Exp (PatternTuple pattern) -> Decomposed Exp pattern---{- |-Analogus to 'MultiValue.modifyMultiValue'.--}-modify ::-   (Compose a, Decompose pattern) =>-   pattern ->-   (Decomposed Exp pattern -> a) ->-   Exp (PatternTuple pattern) -> Exp (Composed a)-modify p f = compose . f . decompose p--modify2 ::-   (Compose a, Decompose patternA, Decompose patternB) =>-   patternA ->-   patternB ->-   (Decomposed Exp patternA -> Decomposed Exp patternB -> a) ->-   Exp (PatternTuple patternA) -> Exp (PatternTuple patternB) -> Exp (Composed a)-modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b)----instance Compose (Exp a) where-   type Composed (Exp a) = a-   compose = id--instance Decompose (Atom a) where-   decompose _ = id----instance Compose () where-   type Composed () = ()-   compose = cons--instance Decompose () where-   decompose _ _ = ()---instance (Compose a, Compose b) => Compose (a,b) where-   type Composed (a,b) = (Composed a, Composed b)-   compose = Tuple.uncurry zip . TupleHT.mapPair (compose, compose)--instance (Decompose pa, Decompose pb) => Decompose (pa,pb) where-   decompose (pa,pb) =-      TupleHT.mapPair (decompose pa, decompose pb) . unzip---instance (Compose a, Compose b, Compose c) => Compose (a,b,c) where-   type Composed (a,b,c) = (Composed a, Composed b, Composed c)-   compose = TupleHT.uncurry3 zip3 . TupleHT.mapTriple (compose, compose, compose)--instance-   (Decompose pa, Decompose pb, Decompose pc) =>-      Decompose (pa,pb,pc) where-   decompose (pa,pb,pc) =-      TupleHT.mapTriple (decompose pa, decompose pb, decompose pc) . unzip3---instance (Compose a, Compose b, Compose c, Compose d) => Compose (a,b,c,d) where-   type Composed (a,b,c,d) = (Composed a, Composed b, Composed c, Composed d)-   compose (a,b,c,d) = zip4 (compose a) (compose b) (compose c) (compose d)--instance-   (Decompose pa, Decompose pb, Decompose pc, Decompose pd) =>-      Decompose (pa,pb,pc,pd) where-   decompose (pa,pb,pc,pd) x =-      case unzip4 x of-         (a,b,c,d) ->-            (decompose pa a, decompose pb b, decompose pc c, decompose pd d)---instance (Compose a) => Compose (Complex a) where-   type Composed (Complex a) = Complex (Composed a)-   compose (r:+i) = consComplex (compose r) (compose i)--instance (Decompose p) => Decompose (Complex p) where-   decompose (pr:+pi) =-      Tuple.uncurry (:+) .-      TupleHT.mapPair (decompose pr, decompose pi) . deconsComplex--{- |-You can construct complex numbers this way,-but they will not make you happy,-because the numeric operations require a RealFloat instance-that we could only provide with lots of undefined methods-(also in its superclasses).-You may either define your own arithmetic-or use the NumericPrelude type classes.--}-consComplex :: Exp a -> Exp a -> Exp (Complex a)-consComplex = lift2 MultiValue.consComplex--deconsComplex :: Exp (Complex a) -> (Exp a, Exp a)-deconsComplex c = (lift1 MultiValue.realPart c, lift1 MultiValue.imagPart c)----cons :: (MultiValue.C a) => a -> Exp a-cons = lift0 . MultiValue.cons--unit :: Exp ()-unit = cons ()--zero :: (MultiValue.C a) => Exp a-zero = lift0 MultiValue.zero--add :: (MultiValue.Additive a) => Exp a -> Exp a -> Exp a-add = liftM2 MultiValue.add--sub :: (MultiValue.Additive a) => Exp a -> Exp a -> Exp a-sub = liftM2 MultiValue.sub--mul :: (MultiValue.PseudoRing a) => Exp a -> Exp a -> Exp a-mul = liftM2 MultiValue.mul--sqr :: (MultiValue.PseudoRing a) => Exp a -> Exp a-sqr = liftM $ \x -> MultiValue.mul x x--sqrt :: (MultiValue.Algebraic a) => Exp a -> Exp a-sqrt = liftM MultiValue.sqrt--idiv :: (MultiValue.Integral a) => Exp a -> Exp a -> Exp a-idiv = liftM2 MultiValue.idiv--irem :: (MultiValue.Integral a) => Exp a -> Exp a -> Exp a-irem = liftM2 MultiValue.irem--shl :: (MultiValue.BitShift a) => Exp a -> Exp a -> Exp a-shl = liftM2 MultiValue.shl--shr :: (MultiValue.BitShift a) => Exp a -> Exp a -> Exp a-shr = liftM2 MultiValue.shr--fromInteger' :: (MultiValue.IntegerConstant a) => Integer -> Exp a-fromInteger' = lift0 . MultiValue.fromInteger'--fromRational' :: (MultiValue.RationalConstant a) => Rational -> Exp a-fromRational' = lift0 . MultiValue.fromRational'---cmp ::-   (MultiValue.Comparison a) =>-   LLVM.CmpPredicate -> Exp a -> Exp a -> Exp Bool-cmp ord = liftM2 $ MultiValue.cmp ord--infix 4 ==*, /=*, <*, <=*, >*, >=*--(==*), (/=*), (<*), (>=*), (>*), (<=*) ::-   (MultiValue.Comparison a) => Exp a -> Exp a -> Exp Bool-(==*) = cmp LLVM.CmpEQ-(/=*) = cmp LLVM.CmpNE-(<*)  = cmp LLVM.CmpLT-(>=*) = cmp LLVM.CmpGE-(>*)  = cmp LLVM.CmpGT-(<=*) = cmp LLVM.CmpLE---true, false :: Exp Bool-true = cons True-false = cons False--infixr 3 &&*-(&&*) :: Exp Bool -> Exp Bool -> Exp Bool-(&&*) = liftM2 MultiValue.and--infixr 2 ||*-(||*) :: Exp Bool -> Exp Bool -> Exp Bool-(||*) = liftM2 MultiValue.or--not :: Exp Bool -> Exp Bool-not = liftM MultiValue.inv--{- |-Like 'ifThenElse' but computes both alternative expressions-and then uses LLVM's efficient @select@ instruction.--}-select :: (MultiValue.Select a) => Exp Bool -> Exp a -> Exp a -> Exp a-select = liftM3 MultiValue.select--ifThenElse :: (MultiValue.C a) => Exp Bool -> Exp a -> Exp a -> Exp a-ifThenElse ec ex ey =-   Exp (do-      MultiValue.Cons c <- unExp ec-      C.ifThenElse c (unExp ex) (unExp ey))---complement :: (MultiValue.Logic a) => Exp a -> Exp a-complement = liftM MultiValue.inv--infixl 7 .&.*-(.&.*) :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a-(.&.*) = liftM2 MultiValue.and--infixl 5 .|.*-(.|.*) :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a-(.|.*) = liftM2 MultiValue.or--infixl 6 `xor`-xor :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a-xor = liftM2 MultiValue.xor---toMaybe :: Exp Bool -> Exp a -> Exp (Maybe a)-toMaybe = lift2 MultiValue.toMaybe--maybe :: (MultiValue.C b) => Exp b -> (Exp a -> Exp b) -> Exp (Maybe a) -> Exp b-maybe n j = liftM $ \m -> do-   let (MultiValue.Cons b, a) = MultiValue.splitMaybe m-   C.ifThenElse b (unliftM1 j a) (unExp n)-+module Data.Array.Knead.Expression (+   Exp,+   Value,+   lift0,+   lift1,+   lift2,+   lift3,+   lift4,+   liftM,+   liftM2,+   liftM3,+   unliftM1,+   unliftM2,+   unliftM3,+   liftReprM,+   liftReprM2,+   liftReprM3,+   zip,+   zip3,+   zip4,+   unzip,+   unzip3,+   unzip4,+   fst,+   snd,+   mapFst,+   mapSnd,+   mapPair,+   swap,+   curry,+   uncurry,+   fst3,+   snd3,+   thd3,+   mapFst3,+   mapSnd3,+   mapThd3,+   mapTriple,+   tuple,+   untuple,+   modifyNiceValue,+   modifyNiceValue2,+   modifyNiceValueM,+   modifyNiceValueM2,+   Compose(..),+   Decompose(..),+   modify,+   modify2,+   consComplex,+   deconsComplex,+   cons,+   unit,+   zero,+   add,+   sub,+   mul,+   sqr,+   sqrt,+   idiv,+   irem,+   shl,+   shr,+   fromInteger',+   fromRational',+   boolPFrom8,+   bool8FromP,+   intFromBool8,+   floatFromBool8,+   fromFastMath,+   toFastMath,+   minBound, maxBound,+   cmp,+   (==*), (/=*), (<*), (>=*), (>*), (<=*),+   min, max,+   true, false,+   (&&*),+   (||*),+   not,+   select,+   ifThenElse,+   complement,+   (.&.*),+   (.|.*),+   xor,+   toMaybe,+   maybe,+   ) where -instance-   (MultiValue.PseudoRing a, MultiValue.Real a, MultiValue.IntegerConstant a) =>-      Num (Exp a) where-   fromInteger n = lift0 (MultiValue.fromInteger' n)-   (+) = liftM2 MultiValue.add-   (-) = liftM2 MultiValue.sub-   negate = liftM MultiValue.neg-   (*) = liftM2 MultiValue.mul-   abs = liftM MultiValue.abs-   signum = liftM MultiValue.signum+import LLVM.DSL.Expression -instance (MultiValue.Field a, MultiValue.Real a, MultiValue.RationalConstant a) =>-      Fractional (Exp a) where-   fromRational n = lift0 (MultiValue.fromRational' n)-   (/) = liftM2 MultiValue.fdiv+import Prelude ()
− src/Data/Array/Knead/Index/Linear.hs 
@@ -1,558 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Data.Array.Knead.Index.Linear (-   C(switch),-   switchInt,-   intersect,-   value,-   constant,-   paramWith,-   tunnel,-   flattenIndex,-   peek,-   poke,-   computeSize,--   Struct,-   T(..),-   Z(Z), z,-   (:.)((:.)),-   Shape, shape,-   Index, index,-   cons, (#:.),-   head,-   tail,-   switchR,-   loadMultiValue,-   storeMultiValue,-   ) where--import qualified Data.Array.Knead.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Index.Linear.Int as Index--import qualified Data.Array.Knead.Parameter as Param-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, )--import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C-import LLVM.Extra.Multi.Value (Atom, )--import qualified LLVM.Util.Loop as Loop-import qualified LLVM.Core as LLVM--import qualified Foreign.Storable as St-import Foreign.Storable.FixedArray (sizeOfArray, )-import Foreign.Marshal.Array (advancePtr, )-import Foreign.Ptr (Ptr, castPtr, )--import Control.Monad (liftM2, )-import Data.Word (Word32, )--import Prelude hiding (min, head, tail, )---class C ix where-   switch ::-      f Z ->-      (forall ix0 i. (C ix0, Index.Single i) => f (ix0 :. i)) ->-      f ix--instance C Z where-   switch x _ = x--instance (C ix0, Index.Single i) => C (ix0 :. i) where-   switch _ x = x---newtype SwitchInt f ix i = SwitchInt {runSwitchInt :: f (ix :. i)}--switchInt ::-   (C ix) =>-   f Z ->-   (forall ix0. (C ix0) => f (ix0 :. Index.Int)) ->-   f ix-switchInt z0 cons0 =-   switch z0-      (runSwitchInt $ Index.switchSingle (SwitchInt cons0))---newtype Op2 tag sh = Op2 {runOp2 :: Exp (T tag sh) -> Exp (T tag sh) -> Exp (T tag sh)}--intersect :: C sh => Exp (Shape sh) -> Exp (Shape sh) -> Exp (Shape sh)-intersect =-   runOp2 $-   switchInt-      (Op2 $ \z0 _ -> z0)-      (Op2 $-       switchR $ \is i ->-       switchR $ \js j ->-          intersect is js #:. Expr.min i j)---_value :: (C sh, MultiValue.C sh) => sh -> Exp sh-_value = Expr.lift0 . MultiValue.cons---newtype MakeValue val tag sh = MakeValue {runMakeValue :: T tag sh -> val (T tag sh)}--value :: (C sh, Expr.Value val) => T tag sh -> val (T tag sh)-value =-   runMakeValue $-   switchInt-      (MakeValue $ \(Cons Z) -> z)-      (MakeValue $ \(Cons (t:.h)) ->-         value (Cons t) #:. Expr.lift0 (MultiValue.cons h))--paramWith ::-   (C sh, Expr.Value val) =>-   Param.T p (T tag sh) ->-   (forall parameters.-    (St.Storable parameters,-     MultiValueMemory.C parameters) =>-    (p -> parameters) ->-    (MultiValue.T parameters -> val (T tag sh)) ->-    a) ->-   a-paramWith p f =-   case tunnel p of-      Param.Tunnel get val -> f get (Expr.lift0 . val)--tunnel :: (C sh) => Param.T p (T tag sh) -> Param.Tunnel p (T tag sh)-tunnel p =-   case structFieldsPropF p of-      StructFieldsProp -> Param.tunnel value p---data StructFieldsProp sh = LLVM.StructFields (Struct sh) => StructFieldsProp--_structFieldsProp :: (C sh) => f sh -> StructFieldsProp sh-_structFieldsProp _p = structFieldsRec--structFieldsPropF :: (C sh) => f (g sh) -> StructFieldsProp sh-structFieldsPropF _p = structFieldsRec--withStructFieldsPropFF ::-   (C sh) => (StructFieldsProp sh -> f (g (h sh))) -> f (g (h sh))-withStructFieldsPropFF f = f structFieldsRec--structFieldsRec :: (C sh) => StructFieldsProp sh-structFieldsRec =-   switchInt-      StructFieldsProp-      (succStructFieldsProp structFieldsRec)--succStructFieldsProp ::-   StructFieldsProp sh -> StructFieldsProp (sh:.Index.Int)-succStructFieldsProp StructFieldsProp = StructFieldsProp---data Z = Z-   deriving (Eq, Ord, Read, Show)---infixl 3 :., #:.--data tail :. head = !tail :. !head-   deriving (Eq, Ord, Read, Show)---newtype T tag sh = Cons {decons :: sh}--data ShapeTag-data IndexTag--type Shape = T ShapeTag-type Index = T IndexTag--shape :: sh -> Shape sh-shape = Cons--index :: ix -> Index ix-index = Cons---(#:.) :: (Expr.Value val) => val (T tag sh) -> val i -> val (T tag (sh:.i))-(#:.) = cons--cons :: (Expr.Value val) => val (T tag sh) -> val i -> val (T tag (sh:.i))-cons =-   Expr.lift2 $-      \(MultiValue.Cons t) (MultiValue.Cons h) ->-         MultiValue.Cons (t,h)--z :: (Expr.Value val) => val (T tag Z)-z = Expr.lift0 $ MultiValue.Cons ()--head :: (Expr.Value val) => val (T tag (sh:.i)) -> val i-head = Expr.lift1 $ \(MultiValue.Cons (_t,h)) -> MultiValue.Cons h--tail :: (Expr.Value val) => val (T tag (sh:.i)) -> val (T tag sh)-tail = Expr.lift1 $ \(MultiValue.Cons (t,_h)) -> MultiValue.Cons t--switchR ::-   Expr.Value val =>-   (val (T tag sh) -> val i -> a) -> val (T tag (sh :. i)) -> a-switchR f ix = f (tail ix) (head ix)---instance (tag ~ ShapeTag, sh ~ Z) => Shape.Scalar (T tag sh) where-   scalar = Expr.lift0 $ MultiValue.Cons ()-   zeroIndex _ = Expr.lift0 $ MultiValue.Cons ()---type family PatternTuple pattern-type family Decomposed (f :: * -> *) tag pattern--type instance PatternTuple (sh:.s) =-   PatternTuple sh :. MultiValue.PatternTuple s--type instance Decomposed f tag (sh:.s) =-   Decomposed f tag sh :. MultiValue.Decomposed f s--type instance PatternTuple (Atom sh) = sh--type instance Decomposed f tag (Atom sh) = f (T tag sh)---class-   (Expr.Composed (Decomposed Exp tag pattern) ~ T tag (PatternTuple pattern)) =>-      Decompose tag pattern where-   decompose ::-      T tag pattern -> Exp (T tag (PatternTuple pattern)) ->-      Decomposed Exp tag pattern--instance Decompose tag (Atom sh) where-   decompose (Cons _atom) x = x--instance (Decompose tag sh, Expr.Decompose s) => Decompose tag (sh :. s) where-   decompose (Cons (psh:.ps)) x =-      decompose (Cons psh) (tail x) :. Expr.decompose ps (head x)---type instance MultiValue.PatternTuple (T tag sh) = T tag (PatternTuple sh)--type instance MultiValue.Decomposed f (T tag sh) = Decomposed f tag sh---type family Unwrap sh-type instance Unwrap (T tag sh) = sh--type family Tag sh-type instance Tag (T tag sh) = tag--instance-   (Expr.Compose sh,-    Expr.Composed sh ~ T (Tag (Expr.Composed sh)) (Unwrap (Expr.Composed sh)),-    Expr.Compose s) =>-      Expr.Compose (sh :. s) where-   type Composed (sh :. s) =-           T (Tag (Expr.Composed sh))-             (Unwrap (Expr.Composed sh) :. Expr.Composed s)-   compose (sh :. s) = cons (Expr.compose sh) (Expr.compose s)--instance (Decompose tag sh) => Expr.Decompose (T tag sh) where-   decompose = decompose----instance (C sh) => St.Storable (T tag sh) where-   sizeOf (Cons sh) = sizeOfArray (rank sh) (0::Word32)-   alignment (Cons _sh) = St.alignment (0::Word32)-   poke ptr = poke (castPtr ptr) . decons-   peek = fmap Cons . peek . castPtr---type family Repr (f :: * -> *) sh-type instance Repr f Z = ()-type instance Repr f (tail :. head) = (Repr f tail, MultiValue.Repr f head)--instance (C sh) => MultiValue.C (T tag sh) where-   type Repr f (T tag sh) = Repr f sh-   cons = value-   undef = constant $ MultiValue.undef-   zero = constant $ MultiValue.zero-   addPhis = addPhis-   phis = phis--instance (tag ~ ShapeTag, C sh) => Shape.C (T tag sh) where-   type Index (T tag sh) = Index sh-   size = fromIntegral . size . decons-   sizeCode = computeSize-   intersectCode = Expr.unliftM2 intersect-   flattenIndexRec sh ix =-      -- a joint implementation would not be more efficient-      liftM2 (,)-         (computeSize sh)-         (flattenIndex sh ix)-   loop = loop---type family Struct sh-type instance Struct Z = ()-type instance Struct (sh :. Index.Int) = (Word32, Struct sh)--instance-   (C sh, LLVM.StructFields (Struct sh)) =>-      MultiValueMemory.C (T tag sh) where-   type Struct (T tag sh) = LLVM.Struct (Struct sh)-   load = loadMultiValue-   store = storeMultiValue--loadMultiValue ::-   (C sh) =>-   LLVM.Value (Ptr (LLVM.Struct (Struct sh))) ->-   LLVM.CodeGenFunction r (MultiValue.T (T tag sh))-loadMultiValue ptr =-   withStructFieldsPropFF $ \StructFieldsProp ->-      load =<< castPtrValue ptr--storeMultiValue ::-   (C sh) =>-   MultiValue.T (T tag sh) ->-   LLVM.Value (Ptr (LLVM.Struct (Struct sh))) -> LLVM.CodeGenFunction r ()-storeMultiValue x ptr =-   case structFieldsPropF x of-      StructFieldsProp -> store x =<< castPtrValue ptr---newtype FlattenIndex r sh =-   FlattenIndex {-      runFlattenIndex ::-         MultiValue.T (Shape sh) -> MultiValue.T (Index sh) ->-         LLVM.CodeGenFunction r (LLVM.Value Word32)-   }--flattenIndex ::-   (C sh) =>-   MultiValue.T (Shape sh) -> MultiValue.T (Index sh) ->-   LLVM.CodeGenFunction r (LLVM.Value Word32)-flattenIndex =-   runFlattenIndex $-   switchInt-      (FlattenIndex $ \_zerosh _zeroix -> return A.zero)-      (FlattenIndex $-         switchR $ \sh (MultiValue.Cons s) ->-         switchR $ \ix (MultiValue.Cons i) ->-            A.add i =<< A.mul s =<< flattenIndex sh ix)---newtype Rank sh = Rank {runRank :: sh -> Int}--rank :: (C sh) => sh -> Int-rank =-   runRank $-   switch-      (Rank $ const 0)-      (Rank $ succ . rank . (\(sh :. _s) -> sh))---newtype Peek sh = Peek {runPeek :: Ptr Word32 -> IO sh}--peek :: (C sh) => Ptr Word32 -> IO sh-peek =-   runPeek $-   switchInt-      (Peek $ const $ return Z)-      (Peek $ \ptr -> do-         h <- St.peek ptr-         t <- peek $ advancePtr ptr 1-         return (t :. Index.Int h))---newtype Poke sh = Poke {runPoke :: Ptr Word32 -> sh -> IO ()}--poke :: (C sh) => Ptr Word32 -> sh -> IO ()-poke =-   runPoke $-   switchInt-      (Poke $ const $ const $ return ())-      (Poke $ \ptr (sh :. Index.Int i) -> do-         St.poke ptr i-         poke (advancePtr ptr 1) sh)---castPtrValue ::-   (LLVM.StructFields sh) =>-   LLVM.Value (Ptr (LLVM.Struct sh)) ->-   LLVM.CodeGenFunction r (LLVM.Value (Ptr Word32))-castPtrValue = LLVM.bitcast--newtype Load r tag sh =-   Load {-      runLoad ::-         LLVM.Value (Ptr Word32) ->-         LLVM.CodeGenFunction r (MultiValue.T (T tag sh))-   }--load ::-   (C sh) =>-   LLVM.Value (Ptr Word32) ->-   LLVM.CodeGenFunction r (MultiValue.T (T tag sh))-load =-   runLoad $-   switchInt-      (Load $ const $ return z)-      (Load $ \ptr -> do-         h <- LLVM.load ptr-         t <- load =<< A.advanceArrayElementPtr ptr-         return (t #:. MultiValue.Cons h))---newtype Store r tag sh =-   Store {-      runStore ::-         MultiValue.T (T tag sh) ->-         LLVM.Value (Ptr Word32) ->-         LLVM.CodeGenFunction r ()-   }--store ::-   (C sh) =>-   MultiValue.T (T tag sh) ->-   LLVM.Value (Ptr Word32) ->-   LLVM.CodeGenFunction r ()-store =-   runStore $-   switchInt-      (Store $ \_z _ptr -> return ())-      (Store $ switchR $ \sh (MultiValue.Cons k) ptr -> do-         LLVM.store k ptr-         store sh =<< A.advanceArrayElementPtr ptr)---newtype Size sh =-   Size {-      runSize :: sh -> Word32-   }--size :: (C sh) => sh -> Word32-size =-   runSize $-   switchInt-      (Size $ \_z -> 1)-      (Size $ \(sh :. Index.Int k) -> k * size sh)---newtype ComputeSize r sh =-   ComputeSize {-      runComputeSize ::-         MultiValue.T (Shape sh) ->-         LLVM.CodeGenFunction r (LLVM.Value Word32)-   }--computeSize ::-   (C sh) =>-   MultiValue.T (Shape sh) ->-   LLVM.CodeGenFunction r (LLVM.Value Word32)-computeSize =-   runComputeSize $-   switchInt-      (ComputeSize $ \_z -> return A.one)-      (ComputeSize $ switchR $ \sh (MultiValue.Cons k) ->-         A.mul k =<< computeSize sh)---newtype-   Constant val tag sh =-      Constant {getConstant :: val Index.Int -> val (T tag sh)}--constant :: (C sh, Expr.Value val) => val Index.Int -> val (T tag sh)-constant =-   getConstant $-   switchInt-      (Constant $ const z)-      (Constant $ \x -> constant x #:. x)---newtype AddPhis r tag sh =-   AddPhis {-      runAddPhis ::-         LLVM.BasicBlock ->-         MultiValue.T (T tag sh) ->-         MultiValue.T (T tag sh) ->-         LLVM.CodeGenFunction r ()-   }--addPhis ::-   (C sh) =>-   LLVM.BasicBlock ->-   MultiValue.T (T tag sh) ->-   MultiValue.T (T tag sh) ->-   LLVM.CodeGenFunction r ()-addPhis =-   runAddPhis $-   switchInt-      (AddPhis $ \_ _ _ -> return ())-      (AddPhis $ \bb ->-       switchR $ \hx tx ->-       switchR $ \hy ty ->-          MultiValue.addPhis bb tx ty >>-          addPhis bb hx hy)---newtype Phis r tag sh =-   Phis {-      runPhis ::-         LLVM.BasicBlock ->-         MultiValue.T (T tag sh) ->-         LLVM.CodeGenFunction r (MultiValue.T (T tag sh))-   }--phis ::-   (C sh) =>-   LLVM.BasicBlock ->-   MultiValue.T (T tag sh) ->-   LLVM.CodeGenFunction r (MultiValue.T (T tag sh))-phis =-   runPhis $-   switchInt-      (Phis $ \_ -> return)-      (Phis $ \bb ->-       switchR $ \h t ->-          liftM2 (#:.)-             (phis bb h)-             (MultiValue.phis bb t))---newtype Loop r state sh =-   Loop {-      runLoop ::-         (MultiValue.T (Index sh) ->-          state ->-          LLVM.CodeGenFunction r state) ->-         MultiValue.T (Shape sh) ->-         state ->-         LLVM.CodeGenFunction r state-   }--loop ::-   (C sh, Loop.Phi state) =>-   (MultiValue.T (Index sh) ->-    state ->-    LLVM.CodeGenFunction r state) ->-   MultiValue.T (Shape sh) ->-   state ->-   LLVM.CodeGenFunction r state-loop =-   runLoop $-   switchInt-      (Loop $ \code _z -> code z)-      (Loop $ \code -> switchR $ \sh (MultiValue.Cons n) ->-         loop-            (\ix ptrStart ->-               fmap fst $-               C.fixedLengthLoop n (ptrStart, A.zero) $ \(ptr, k) ->-                  liftM2 (,)-                     (code (ix #:. MultiValue.Cons k) ptr)-                     (A.inc k))-            sh)
− src/Data/Array/Knead/Index/Linear/Int.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module Data.Array.Knead.Index.Linear.Int (-   Single(..),-   Int(Int), cons, decons,-   ) where--import qualified Data.Array.Knead.Expression as Expr--import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Arithmetic as A--import Data.Word (Word32, )--import Prelude hiding (Int, head, tail, )---newtype Int = Int Word32--cons :: (Expr.Value val) => val Word32 -> val Int-cons = Expr.lift1 $ \(MultiValue.Cons x) -> MultiValue.Cons x--decons :: (Expr.Value val) => val Int -> val Word32-decons = Expr.lift1 $ \(MultiValue.Cons x) -> MultiValue.Cons x---class Single ix where-   switchSingle :: f Int -> f ix--instance Single Int where-   switchSingle x = x---instance MultiValue.C Int where-   type Repr f Int = f Word32-   cons (Int x) = MultiValue.consPrimitive x-   undef = MultiValue.undefPrimitive-   zero = MultiValue.zeroPrimitive-   phis = MultiValue.phisPrimitive-   addPhis = MultiValue.addPhisPrimitive--instance MultiValue.Additive Int where-   add = MultiValue.liftM2 A.add-   sub = MultiValue.liftM2 A.sub-   neg = MultiValue.liftM A.neg--instance MultiValue.PseudoRing Int where-   mul = MultiValue.liftM2 A.mul--instance MultiValue.Real Int where-   min = MultiValue.liftM2 A.min-   max = MultiValue.liftM2 A.max-   abs = MultiValue.liftM A.abs-   signum = MultiValue.liftM A.signum--instance MultiValue.IntegerConstant Int where-   fromInteger' = cons . A.fromInteger'--instance MultiValue.Comparison Int where-   cmp mode = MultiValue.liftM2 $ A.cmp mode
− src/Data/Array/Knead/Index/Nested/Shape.hs 
@@ -1,505 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-}-module Data.Array.Knead.Index.Nested.Shape (-   C(..),-   value,-   paramWith,-   load,-   intersect,-   flattenIndex,--   Range(..),-   Shifted(..),--   Scalar(..),-   ) where--import qualified Data.Array.Knead.Expression as Expr-import qualified Data.Array.Knead.Parameter as Param-import Data.Array.Knead.Expression (Exp, )--import qualified LLVM.Extra.Multi.Value.Memory as MultiMem-import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C-import LLVM.Extra.Multi.Value (atom)-import LLVM.Extra.Monad (liftR2)--import qualified LLVM.Util.Loop as Loop-import qualified LLVM.Core as LLVM--import qualified Type.Data.Num.Decimal as TypeNum--import Foreign.Storable-         (Storable, sizeOf, alignment, poke, peek, pokeElemOff, peekElemOff)-import Foreign.Ptr (Ptr, castPtr)--import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int8, Int16, Int32, Int64)--import qualified Control.Monad.HT as Monad-import Control.Applicative ((<$>))---value :: (C sh, Expr.Value val) => sh -> val sh-value = Expr.lift0 . MultiValue.cons--paramWith ::-   (Storable b, MultiMem.C b, Expr.Value val) =>-   Param.T p b ->-   (forall parameters.-    (Storable parameters, MultiMem.C parameters) =>-    (p -> parameters) ->-    (MultiValue.T parameters -> val b) ->-    a) ->-   a-paramWith p f =-   Param.withMulti p (\get val -> f get (Expr.lift0 . val))--load ::-   (MultiMem.C sh) =>-   f sh -> LLVM.Value (Ptr (MultiMem.Struct sh)) ->-   LLVM.CodeGenFunction r (MultiValue.T sh)-load _ = MultiMem.load--intersect :: (C sh) => Exp sh -> Exp sh -> Exp sh-intersect = Expr.liftM2 intersectCode--flattenIndex ::-   (C sh) =>-   MultiValue.T sh -> MultiValue.T (Index sh) ->-   LLVM.CodeGenFunction r (LLVM.Value Word32)-flattenIndex sh ix =-   fmap snd $ flattenIndexRec sh ix--class (MultiValue.C sh) => C sh where-   type Index sh :: *-   {--   It would be better to restrict zipWith to matching shapes-   and turn shape intersection into a bound check.-   -}-   intersectCode ::-      MultiValue.T sh -> MultiValue.T sh ->-      LLVM.CodeGenFunction r (MultiValue.T sh)-   sizeCode ::-      MultiValue.T sh ->-      LLVM.CodeGenFunction r (LLVM.Value Word32)-   size :: sh -> Int-   {- |-   Result is @(size, flattenedIndex)@.-   @size@ must equal the result of 'sizeCode'.-   We use this for sharing intermediate results.-   -}-   flattenIndexRec ::-      MultiValue.T sh -> MultiValue.T (Index sh) ->-      LLVM.CodeGenFunction r (LLVM.Value Word32, LLVM.Value Word32)-   loop ::-      (Index sh ~ ix, Loop.Phi state) =>-      (MultiValue.T ix -> state -> LLVM.CodeGenFunction r state) ->-      MultiValue.T sh -> state -> LLVM.CodeGenFunction r state---instance C () where-   type Index () = ()-   intersectCode _ _ = return $ MultiValue.cons ()-   sizeCode _ = return A.one-   size _ = 1-   flattenIndexRec _ _ = return (A.one, A.zero)-   loop = id---class C sh => Scalar sh where-   scalar :: (Expr.Value val) => val sh-   zeroIndex :: (Expr.Value val) => f sh -> val (Index sh)--instance Scalar () where-   scalar = Expr.lift0 $ MultiValue.Cons ()-   zeroIndex _ = Expr.lift0 $ MultiValue.Cons ()---loopPrimitive ::-   (MultiValue.Repr LLVM.Value j ~ LLVM.Value j,-    Num j, LLVM.IsConst j, LLVM.IsInteger j,-    LLVM.CmpRet j, LLVM.CmpResult j ~ Bool,-    MultiValue.Additive i, MultiValue.IntegerConstant i,-    Loop.Phi state) =>-   (MultiValue.T i -> state -> LLVM.CodeGenFunction r state) ->-   MultiValue.T j -> state -> LLVM.CodeGenFunction r state-loopPrimitive code (MultiValue.Cons n) ptrStart =-   loopStart code n MultiValue.zero ptrStart--loopStart ::-   (Num j, LLVM.IsConst j, LLVM.IsInteger j,-    LLVM.CmpRet j, LLVM.CmpResult j ~ Bool,-    MultiValue.Additive i, MultiValue.IntegerConstant i,-    Loop.Phi state) =>-   (MultiValue.T i -> state -> LLVM.CodeGenFunction r state) ->-   LLVM.Value j ->-   MultiValue.T i -> state -> LLVM.CodeGenFunction r state-loopStart code n start ptrStart =-   fmap fst $-   C.fixedLengthLoop n (ptrStart, start) $ \(ptr, k) ->-      Monad.lift2 (,) (code k ptr) (MultiValue.inc k)--instance C Word32 where-   type Index Word32 = Word32-   intersectCode = MultiValue.min-   sizeCode (MultiValue.Cons n) = return n-   size = fromIntegral-   flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) = return (n, i)-   loop = loopPrimitive--instance C Word64 where-   type Index Word64 = Word64-   intersectCode = MultiValue.min-   sizeCode (MultiValue.Cons n) = LLVM.trunc n-   size = fromIntegral-   flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) =-      Monad.lift2 (,) (LLVM.trunc n) (LLVM.trunc i)-   loop = loopPrimitive---{- |-Array dimensions and indexes cannot be negative,-but computations in indices may temporarily yield negative values-or we want to add negative values to indices.--Maybe we should better have type Index Word64 = Int64?--}-unsigned8 :: LLVM.Value Int8 -> LLVM.CodeGenFunction r (LLVM.Value Word8)-unsigned8 = LLVM.bitcast--instance C Int8 where-   type Index Int8 = Int8-   intersectCode = MultiValue.min-   sizeCode (MultiValue.Cons n) = LLVM.ext =<< unsigned8 n-   size = fromIntegral-   flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) =-      Monad.lift2 (,) (LLVM.ext =<< unsigned8 n) (LLVM.ext =<< unsigned8 i)-   loop = loopPrimitive--unsigned16 :: LLVM.Value Int16 -> LLVM.CodeGenFunction r (LLVM.Value Word16)-unsigned16 = LLVM.bitcast--instance C Int16 where-   type Index Int16 = Int16-   intersectCode = MultiValue.min-   sizeCode (MultiValue.Cons n) = LLVM.ext =<< unsigned16 n-   size = fromIntegral-   flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) =-      Monad.lift2 (,) (LLVM.ext =<< unsigned16 n) (LLVM.ext =<< unsigned16 i)-   loop = loopPrimitive--instance C Int32 where-   type Index Int32 = Int32-   intersectCode = MultiValue.min-   sizeCode (MultiValue.Cons n) = LLVM.bitcast n-   size = fromIntegral-   flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) =-      Monad.lift2 (,) (LLVM.bitcast n) (LLVM.bitcast i)-   loop = loopPrimitive--instance C Int64 where-   type Index Int64 = Int64-   intersectCode = MultiValue.min-   sizeCode (MultiValue.Cons n) = LLVM.trunc n-   size = fromIntegral-   flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) =-      Monad.lift2 (,) (LLVM.trunc n) (LLVM.trunc i)-   loop = loopPrimitive---{- |-'Range' denotes an inclusive range like-those of the Haskell 98 standard @Array@ type from the @array@ package.-E.g. the shape type @(Range Int32, Range Int64)@-is equivalent to the ix type @(Int32, Int64)@ for @Array@s.--}-data Range n = Range n n--singletonRange :: n -> Range n-singletonRange n = Range n n---{-# INLINE castToElemPtr #-}-castToElemPtr :: Ptr (f a) -> Ptr a-castToElemPtr = castPtr---- cf. sample-frame:Stereo-instance Storable n => Storable (Range n) where-   {-# INLINE sizeOf #-}-   {-# INLINE alignment #-}-   {-# INLINE peek #-}-   {-# INLINE poke #-}-   sizeOf ~(Range l r) = sizeOf l + mod (- sizeOf l) (alignment r) + sizeOf r-   alignment ~(Range l _) = alignment l-   poke p (Range l r) =-      let q = castToElemPtr p-      in  poke q l >> pokeElemOff q 1 r-   peek p =-      let q = castToElemPtr p-      in  Monad.lift2 Range (peek q) (peekElemOff q 1)---class-   (MultiValue.Additive n, MultiValue.Real n, MultiValue.IntegerConstant n) =>-      ToSize n where-   toSize :: MultiValue.T n -> LLVM.CodeGenFunction r (LLVM.Value Word32)--instance ToSize Word32 where toSize (MultiValue.Cons n) = LLVM.adapt n-instance ToSize Word64 where toSize (MultiValue.Cons n) = LLVM.adapt n-instance ToSize Int32 where toSize (MultiValue.Cons n) = LLVM.bitcast n-instance ToSize Int64 where toSize (MultiValue.Cons n) = LLVM.trunc n--rangeSize ::-   (ToSize n) =>-   Range (MultiValue.T n) -> LLVM.CodeGenFunction r (LLVM.Value Word32)-rangeSize (Range from to) =-   toSize =<< MultiValue.inc =<< MultiValue.sub to from--unzipRange :: MultiValue.T (Range n) -> Range (MultiValue.T n)-unzipRange (MultiValue.Cons (Range from to)) =-   Range (MultiValue.Cons from) (MultiValue.Cons to)--zipRange :: MultiValue.T n -> MultiValue.T n -> MultiValue.T (Range n)-zipRange (MultiValue.Cons from) (MultiValue.Cons to) =-   MultiValue.Cons (Range from to)--instance (MultiValue.C n) => MultiValue.C (Range n) where-   type Repr f (Range n) = Range (MultiValue.Repr f n)-   cons (Range from to) = zipRange (MultiValue.cons from) (MultiValue.cons to)-   undef = MultiValue.compose $ singletonRange MultiValue.undef-   zero = MultiValue.compose $ singletonRange MultiValue.zero-   phis bb a =-      case unzipRange a of-         Range a0 a1 ->-            Monad.lift2 zipRange (MultiValue.phis bb a0) (MultiValue.phis bb a1)-   addPhis bb a b =-      case (unzipRange a, unzipRange b) of-         (Range a0 a1, Range b0 b1) ->-            MultiValue.addPhis bb a0 b0 >>-            MultiValue.addPhis bb a1 b1--type instance-   MultiValue.Decomposed f (Range pn) =-      Range (MultiValue.Decomposed f pn)-type instance-   MultiValue.PatternTuple (Range pn) =-      Range (MultiValue.PatternTuple pn)--instance (MultiValue.Compose n) => MultiValue.Compose (Range n) where-   type Composed (Range n) = Range (MultiValue.Composed n)-   compose (Range from to) =-      zipRange (MultiValue.compose from) (MultiValue.compose to)--instance (MultiValue.Decompose pn) => MultiValue.Decompose (Range pn) where-   decompose (Range pfrom pto) rng =-      case unzipRange rng of-         Range from to ->-            Range-               (MultiValue.decompose pfrom from)-               (MultiValue.decompose pto to)--instance (MultiMem.C n) => MultiMem.C (Range n) where-   type Struct (Range n) = PairStruct n-   decompose = fmap (uncurry zipRange) . decomposeGen-   compose x = case unzipRange x of Range n m -> composeGen n m--instance (Integral n, ToSize n) => C (Range n) where-   type Index (Range n) = n-   intersectCode =-      MultiValue.modifyF2 (singletonRange atom) (singletonRange atom) $-            \(Range fromN toN) (Range fromM toM) ->-         Monad.lift2 Range (MultiValue.max fromN fromM) (MultiValue.min toN toM)-   sizeCode = rangeSize . unzipRange-   size (Range from to) = fromIntegral $ to-from+1-   flattenIndexRec rngValue i =-      case unzipRange rngValue of-         rng@(Range from _to) ->-            Monad.lift2 (,) (rangeSize rng) (toSize =<< MultiValue.sub i from)-   loop code rngValue ptrStart =-      case unzipRange rngValue of-         rng@(Range from _to) -> do-            {--            FIXME: rangeSize converts to Word32 which is overly restrictive here.-            -}-            n <- rangeSize rng-            loopStart code n from ptrStart---{- |-'Shifted' denotes a range defined by the start index and the length.--}-data Shifted n = Shifted {shiftedOffset, shiftedSize :: n}--singletonShifted :: n -> Shifted n-singletonShifted n = Shifted n n----- cf. sample-frame:Stereo-instance Storable n => Storable (Shifted n) where-   {-# INLINE sizeOf #-}-   {-# INLINE alignment #-}-   {-# INLINE peek #-}-   {-# INLINE poke #-}-   sizeOf ~(Shifted l n) = sizeOf l + mod (- sizeOf l) (alignment n) + sizeOf n-   alignment ~(Shifted l _) = alignment l-   poke p (Shifted l n) =-      let q = castToElemPtr p-      in  poke q l >> pokeElemOff q 1 n-   peek p =-      let q = castToElemPtr p-      in  Monad.lift2 Shifted (peek q) (peekElemOff q 1)---unzipShifted :: MultiValue.T (Shifted n) -> Shifted (MultiValue.T n)-unzipShifted (MultiValue.Cons (Shifted from to)) =-   Shifted (MultiValue.Cons from) (MultiValue.Cons to)--zipShifted :: MultiValue.T n -> MultiValue.T n -> MultiValue.T (Shifted n)-zipShifted (MultiValue.Cons from) (MultiValue.Cons to) =-   MultiValue.Cons (Shifted from to)--instance (MultiValue.C n) => MultiValue.C (Shifted n) where-   type Repr f (Shifted n) = Shifted (MultiValue.Repr f n)-   cons (Shifted offset len) =-      zipShifted (MultiValue.cons offset) (MultiValue.cons len)-   undef = MultiValue.compose $ singletonShifted MultiValue.undef-   zero = MultiValue.compose $ singletonShifted MultiValue.zero-   phis bb a =-      case unzipShifted a of-         Shifted a0 a1 ->-            Monad.lift2 zipShifted-               (MultiValue.phis bb a0) (MultiValue.phis bb a1)-   addPhis bb a b =-      case (unzipShifted a, unzipShifted b) of-         (Shifted a0 a1, Shifted b0 b1) ->-            MultiValue.addPhis bb a0 b0 >>-            MultiValue.addPhis bb a1 b1--type instance-   MultiValue.Decomposed f (Shifted pn) =-      Shifted (MultiValue.Decomposed f pn)-type instance-   MultiValue.PatternTuple (Shifted pn) =-      Shifted (MultiValue.PatternTuple pn)--instance (MultiValue.Compose n) => MultiValue.Compose (Shifted n) where-   type Composed (Shifted n) = Shifted (MultiValue.Composed n)-   compose (Shifted offset len) =-      zipShifted (MultiValue.compose offset) (MultiValue.compose len)--instance (MultiValue.Decompose pn) => MultiValue.Decompose (Shifted pn) where-   decompose (Shifted poffset plen) rng =-      case unzipShifted rng of-         Shifted offset len ->-            Shifted-               (MultiValue.decompose poffset offset)-               (MultiValue.decompose plen len)--instance (MultiMem.C n) => MultiMem.C (Shifted n) where-   type Struct (Shifted n) = PairStruct n-   decompose = fmap (uncurry zipShifted) . decomposeGen-   compose x = case unzipShifted x of Shifted n m -> composeGen n m--type PairStruct n = LLVM.Struct (MultiMem.Struct n, (MultiMem.Struct n, ()))--decomposeGen ::-   (MultiMem.C n) =>-   LLVM.Value (PairStruct n) ->-   LLVM.CodeGenFunction r (MultiValue.T n, MultiValue.T n)-decomposeGen nm =-   Monad.lift2 (,)-      (MultiMem.decompose =<< LLVM.extractvalue nm TypeNum.d0)-      (MultiMem.decompose =<< LLVM.extractvalue nm TypeNum.d1)--composeGen ::-   (MultiMem.C n) =>-   MultiValue.T n -> MultiValue.T n ->-   LLVM.CodeGenFunction r (LLVM.Value (PairStruct n))-composeGen n m = do-   sn <- MultiMem.compose n-   sm <- MultiMem.compose m-   rn <- LLVM.insertvalue (LLVM.value LLVM.undef) sn TypeNum.d0-   LLVM.insertvalue rn sm TypeNum.d1---instance (Integral n, ToSize n) => C (Shifted n) where-   type Index (Shifted n) = n-   intersectCode =-      MultiValue.modifyF2 (singletonShifted atom) (singletonShifted atom) $-            \(Shifted offsetN lenN) (Shifted offsetM lenM) -> do-         offset <- MultiValue.max offsetN offsetM-         endN <- MultiValue.add offsetN lenN-         endM <- MultiValue.add offsetM lenM-         end <- MultiValue.min endN endM-         Shifted offset <$> MultiValue.sub end offset-   sizeCode = toSize . shiftedSize . unzipShifted-   size (Shifted _offset len) = fromIntegral len-   flattenIndexRec shapeValue i =-      case unzipShifted shapeValue of-         Shifted offset len ->-            Monad.lift2 (,) (toSize len) (toSize =<< MultiValue.sub i offset)-   loop code rngValue ptrStart =-      case unzipShifted rngValue of-         Shifted from len -> do-            n <- toSize len-            loopStart code n from ptrStart----instance (C n, C m) => C (n,m) where-   type Index (n,m) = (Index n, Index m)-   intersectCode a b =-      case (MultiValue.unzip a, MultiValue.unzip b) of-         ((an,am), (bn,bm)) ->-            Monad.lift2 MultiValue.zip-               (intersectCode an bn)-               (intersectCode am bm)-   sizeCode nm =-      case MultiValue.unzip nm of-         (n,m) -> liftR2 A.mul (sizeCode n) (sizeCode m)-   size (n,m) = size n * size m-   flattenIndexRec nm ij =-      case (MultiValue.unzip nm, MultiValue.unzip ij) of-         ((n,m), (i,j)) -> do-            (ns, il) <- flattenIndexRec n i-            (ms, jl) <- flattenIndexRec m j-            Monad.lift2 (,)-               (A.mul ns ms)-               (A.add jl =<< A.mul ms il)-   loop code nm =-      case MultiValue.unzip nm of-         (n,m) -> loop (\i -> loop (\j -> code (MultiValue.zip i j)) m) n--instance (C n, C m, C l) => C (n,m,l) where-   type Index (n,m,l) = (Index n, Index m, Index l)-   intersectCode a b =-      case (MultiValue.unzip3 a, MultiValue.unzip3 b) of-         ((ai,aj,ak), (bi,bj,bk)) ->-            Monad.lift3 MultiValue.zip3-               (intersectCode ai bi)-               (intersectCode aj bj)-               (intersectCode ak bk)-   sizeCode nml =-      case MultiValue.unzip3 nml of-         (n,m,l) ->-            liftR2 A.mul (sizeCode n) $-            liftR2 A.mul (sizeCode m) (sizeCode l)-   size (n,m,l) = size n * size m * size l-   flattenIndexRec nml ijk =-      case (MultiValue.unzip3 nml, MultiValue.unzip3 ijk) of-         ((n,m,l), (i,j,k)) -> do-            (ns, il) <- flattenIndexRec n i-            (ms, jl) <- flattenIndexRec m j-            x0 <- A.add jl =<< A.mul ms il-            (ls, kl) <- flattenIndexRec l k-            x1 <- A.add kl =<< A.mul ls x0-            sz <- A.mul ns =<< A.mul ms ls-            return (sz, x1)-   loop code nml =-      case MultiValue.unzip3 nml of-         (n,m,l) ->-             loop (\i -> loop (\j -> loop (\k ->-                code (MultiValue.zip3 i j k))-             l) m) n
− src/Data/Array/Knead/Parameter.hs 
@@ -1,218 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}-module Data.Array.Knead.Parameter where--import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Class as Class-import qualified LLVM.Extra.Memory as Memory-import Foreign.Storable.Tuple ()-import Foreign.Storable (Storable, )--import qualified Control.Category as Cat-import qualified Control.Arrow as Arr-import qualified Control.Applicative as App-import Control.Applicative (pure, liftA2, )--import Data.Tuple.HT (mapFst, )-import Data.Word (Word32, )---{- |-This data type is for parameters of parameterized signal generators and causal processes.-It is better than using plain functions of type @p -> a@-since it allows for numeric instances-and we can make explicit,-whether a parameter is constant.--We recommend to use parameters for atomic types.-Although a parameter of type @T p (a,b)@ is possible,-it means that the whole parameter is variable-if only one of the pair elements is variable.-This way you may miss optimizations.--}-data T p a =-   Constant a |-   Variable (p -> a)---get :: T p a -> (p -> a)-get (Constant a) = const a-get (Variable f) = f---{- |-The call @value param v@ requires-that @v@ represents the same value as @valueTupleOf (get param p)@ for some @p@.-However @v@ might be the result of a load operation-and @param@ might be a constant.-In this case it is more efficient to use @valueTupleOf (get param undefined)@-since the constant is translated to an LLVM constant-that allows for certain optimizations.--This is the main function for taking advantage of a constant parameter-in low-level implementations.-For simplicity we do not omit constant parameters in the parameter struct-since this would mean to construct types at runtime and might become ugly.-Instead we just check using 'value' at the according places in LLVM code-whether a parameter is constant-and ignore the parameter from the struct in this case.-In many cases there will be no speed benefit-because the parameter will be loaded to a register anyway.-It can only lead to speed-up if subsequent optimizations-can precompute constant expressions.-Another example is 'drop' where a loop with constant loop count can be generated.-For small loop counts and simple loop bodies the loop might get unrolled.--}-valueTuple ::-   (Class.MakeValueTuple tuple, Class.ValueTuple tuple ~ value) =>-   T p tuple -> value -> value-valueTuple = genericValue Class.valueTupleOf--multiValue ::-   (MultiValue.C a) =>-   T p a -> MultiValue.T a -> MultiValue.T a-multiValue = genericValue MultiValue.cons--genericValue ::-   (a -> value) ->-   T p a -> value -> value-genericValue cons p v =-   case p of-      Constant a -> cons a-      Variable _ -> v---{- |-This function provides specialised variants of 'get' and 'value',-that use the unit type for constants-and thus save space in parameter structures.--}-withTuple ::-   (Storable tuple, Class.MakeValueTuple tuple,-    Class.ValueTuple tuple ~ value, Memory.C value) =>-   T p tuple ->-   (forall parameters.-    (Storable parameters,-     Class.MakeValueTuple parameters,-     Memory.C (Class.ValueTuple parameters)) =>-    (p -> parameters) ->-    (Class.ValueTuple parameters -> value) ->-    a) ->-   a-withTuple (Constant a) f = f (const ()) (\() -> Class.valueTupleOf a)-withTuple (Variable v) f = f v id--withMulti ::-   (Storable b, MultiValueMemory.C b) =>-   T p b ->-   (forall parameters.-    (Storable parameters,-     MultiValueMemory.C parameters) =>-    (p -> parameters) ->-    (MultiValue.T parameters -> MultiValue.T b) ->-    a) ->-   a-withMulti = with MultiValue.cons--with ::-   (Storable b, MultiValueMemory.C b) =>-   (b -> MultiValue.T b) ->-   T p b ->-   (forall parameters.-    (Storable parameters,-     MultiValueMemory.C parameters) =>-    (p -> parameters) ->-    (MultiValue.T parameters -> MultiValue.T b) ->-    a) ->-   a-with cons p f =-   case p of-      Constant b -> f (const ()) (\_ -> cons b)-      Variable v -> f v id---data Tunnel p a =-   forall t.-   (Storable t, MultiValueMemory.C t) =>-   Tunnel (p -> t) (MultiValue.T t -> MultiValue.T a)--tunnel ::-   (Storable a, MultiValueMemory.C a) =>-   (a -> MultiValue.T a) -> T p a -> Tunnel p a-tunnel cons p =-   case p of-      Constant b -> Tunnel (const ()) (\_ -> cons b)-      Variable v -> Tunnel v id---word32 :: T p Int -> T p Word32-word32 = fmap fromIntegral---infixl 0 $#--($#) :: (T p a -> b) -> (a -> b)-($#) f a = f (pure a)---{- |-@.@ can be used for fetching a parameter from a super-parameter.--}-instance Cat.Category T where-   id = Variable id-   Constant f . _ = Constant f-   Variable f . Constant a = Constant (f a)-   Variable f . Variable g = Variable (f . g)--{- |-@arr@ is useful for lifting parameter selectors to our parameter type-without relying on the constructor.--}-instance Arr.Arrow T where-   arr = Variable-   first f = Variable (mapFst (get f))----{- |-Useful for splitting @T p (a,b)@ into @T p a@ and @T p b@-using @fmap fst@ and @fmap snd@.--}-instance Functor (T p) where-   fmap f (Constant a) = Constant (f a)-   fmap f (Variable g) = Variable (f . g)--{- |-Useful for combining @T p a@ and @T p b@ to @T p (a,b)@-using @liftA2 (,)@.-However, we do not recommend to do so-because the result parameter can only be constant-if both operands are constant.--}-instance App.Applicative (T p) where-   pure a = Constant a-   Constant f <*> Constant a = Constant (f a)-   f <*> a = Variable (\p -> get f p (get a p))--instance Monad (T p) where-   return = pure-   Constant x >>= f = f x-   Variable x >>= f =-      Variable (\p -> get (f (x p)) p)---instance Num a => Num (T p a) where-   (+) = liftA2 (+)-   (-) = liftA2 (-)-   (*) = liftA2 (*)-   negate = fmap negate-   abs = fmap abs-   signum = fmap signum-   fromInteger = pure . fromInteger--instance Fractional a => Fractional (T p a) where-   (/) = liftA2 (/)-   fromRational = pure . fromRational
− src/Data/Array/Knead/Parameterized/Physical.hs 
@@ -1,202 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Data.Array.Knead.Parameterized.Physical (-   Phys.Array,-   Phys.shape,-   Phys.fromList,-   feed,-   the,-   render,-   renderShape,-   mapAccumL,-   foldOuterL,-   scatter,-   scatterMaybe,-   permute,-   ) where--import qualified Data.Array.Knead.Parameterized.PhysicalHull as PhysHull-import qualified Data.Array.Knead.Parameterized.Private as Sym-import qualified Data.Array.Knead.Simple.Physical as Phys-import qualified Data.Array.Knead.Simple.Private as Core-import qualified Data.Array.Knead.Parameter as Param-import qualified Data.Array.Knead.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import qualified Data.Array.Knead.Code as Code-import Data.Array.Knead.Expression (Exp, unExp, )-import Data.Array.Knead.Code (getElementPtr, compile, )--import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Memory as Memory--import qualified LLVM.Core as LLVM--import Foreign.Marshal.Utils (with, )-import Foreign.Marshal.Alloc (alloca, )-import Foreign.Storable (Storable, peek, )-import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, )-import Foreign.Ptr (FunPtr, Ptr, )--import Control.Exception (bracket, )-import Control.Monad.HT ((<=<), )-import Control.Applicative (liftA2, )-import Data.Tuple.HT (mapFst, )-import Data.Word (Word32, )---feed ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    MultiValueMemory.C a) =>-   Param.T p (Phys.Array sh a) -> Sym.Array p sh a-feed arr =-   Param.withMulti (fmap Phys.shape arr) $ \getShape valueShape ->-   Sym.Array-      (\p ->-         case mapFst valueShape $ MultiValue.unzip p of-            (sh, MultiValue.Cons ptr) ->-               Core.Array (Expr.lift0 sh) $-                  Memory.load <=< getElementPtr sh ptr)-      (\p ->-         case Phys.buffer $ Param.get arr p of-            fptr ->-               withForeignPtr fptr $ \ptr ->-                  return (fptr, (getShape p, MultiValueMemory.castStructPtr ptr)))-      touchForeignPtr---type Importer f = FunPtr f -> f--foreign import ccall safe "dynamic" callThe ::-   Importer (Ptr param -> Ptr am -> IO ())---the ::-   (Shape.Scalar z, MultiValueMemory.C a, Storable a) =>-   Sym.Array p z a -> IO (p -> IO a)-the (Sym.Array arr create delete) = do-   func <--      compile "the" $-      Code.createFunction callThe "eval" $-      \paramPtr resultPtr -> do-         param <- Memory.load paramPtr-         case arr param of-            Core.Array z code ->-               code (Shape.zeroIndex z) >>= flip Memory.store resultPtr-         LLVM.ret ()-   return $ \p ->-      bracket (create p) (delete . fst) $ \(_ctx, param) ->-      with param $ \pptr ->-      alloca $ \aptr ->-         func (MultiValueMemory.castStructPtr pptr) (MultiValueMemory.castStructPtr aptr) >>-         peek aptr---foreign import ccall safe "dynamic" callShaper ::-   Importer (Ptr param -> Ptr shape -> IO Word32)---renderShape ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>-   Sym.Array p sh a -> IO (p -> IO (sh, Word32))-renderShape (Sym.Array arr create delete) = do-   fsh <--      compile "renderShape" $-      Code.createFunction callShaper "shape" $-      \paramPtr resultPtr -> do-        param <- Memory.load paramPtr-        case arr param of-           Core.Array esh _code -> do-              sh <- unExp esh-              MultiValueMemory.store sh resultPtr-              Shape.sizeCode sh >>= LLVM.ret-   return $ \p ->-      bracket (create p) (delete . fst) $ \(_ctx, param) ->-      alloca $ \shptr ->-      with param $ \pptr -> do-         let lpptr = MultiValueMemory.castStructPtr pptr-         let lshptr = MultiValueMemory.castStructPtr shptr-         n <- fsh lpptr lshptr-         sh <- peek shptr-         return (sh, n)---render ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>-   Sym.Array p sh a -> IO (p -> IO (Phys.Array sh a))-render = PhysHull.render . Sym.arrayHull---mapAccumL ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    MultiValue.C acc,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>-   (Exp acc -> Exp a -> Exp (acc,b)) ->-   Sym.Array p sh acc ->-   Sym.Array p (sh, n) a ->-   IO (p -> IO (Phys.Array (sh,n) b))-mapAccumL f arrInit arrMap =-   PhysHull.mapAccumL $-      liftA2 (PhysHull.MapAccumL f)-         (Sym.arrayHull arrInit)-         (Sym.arrayHull arrMap)--foldOuterL ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    Storable a, MultiValueMemory.C a) =>-   (Exp a -> Exp b -> Exp a) ->-   Sym.Array p sh a ->-   Sym.Array p (n,sh) b ->-   IO (p -> IO (Phys.Array sh a))-foldOuterL f arrInit arrMap =-   PhysHull.foldOuterL $-      liftA2 (PhysHull.FoldOuterL f)-         (Sym.arrayHull arrInit)-         (Sym.arrayHull arrMap)--scatter ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Storable sh1, MultiValueMemory.C sh1,-    Storable a, MultiValueMemory.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array p sh1 a ->-   Sym.Array p sh0 (ix1, a) -> IO (p -> IO (Phys.Array sh1 a))-scatter accum arrBase arrMap =-   PhysHull.scatter $-      liftA2 (PhysHull.Scatter accum)-         (Sym.arrayHull arrBase)-         (Sym.arrayHull arrMap)--scatterMaybe ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Storable sh1, MultiValueMemory.C sh1,-    Storable a, MultiValueMemory.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array p sh1 a ->-   Sym.Array p sh0 (Maybe (ix1, a)) -> IO (p -> IO (Phys.Array sh1 a))-scatterMaybe accum arrBase arrMap =-   PhysHull.scatterMaybe $-      liftA2 (PhysHull.ScatterMaybe accum)-         (Sym.arrayHull arrBase)-         (Sym.arrayHull arrMap)--permute ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Storable sh1, MultiValueMemory.C sh1,-    Storable a, MultiValueMemory.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array p sh1 a ->-   (Exp ix0 -> Exp ix1) ->-   Sym.Array p sh0 a ->-   IO (p -> IO (Phys.Array sh1 a))-permute accum deflt ixmap input =-   scatter accum deflt-      (Core.mapWithIndex (Expr.lift2 MultiValue.zip . ixmap) input)
− src/Data/Array/Knead/Parameterized/PhysicalHull.hs 
@@ -1,184 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Data.Array.Knead.Parameterized.PhysicalHull (-   render,-   Scatter(..),-   scatter,-   ScatterMaybe(..),-   scatterMaybe,-   MapAccumL(..),-   mapAccumL,-   FoldOuterL(..),-   foldOuterL,-   ) 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.Physical as Phys-import qualified Data.Array.Knead.Simple.Private as Core-import qualified Data.Array.Knead.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Code as Code-import Data.Array.Knead.Expression (Exp, unExp, )-import Data.Array.Knead.Code (compile, )--import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Arithmetic as A--import qualified LLVM.Core as LLVM--import Foreign.Marshal.Utils (with, )-import Foreign.Marshal.Alloc (alloca, )-import Foreign.Storable (Storable, peek, )-import Foreign.ForeignPtr (withForeignPtr, mallocForeignPtrArray, )-import Foreign.Ptr (FunPtr, Ptr, )--import Control.Exception (bracket, )-import Control.Monad.HT (void, )-import Control.Applicative (liftA2, )-import Data.Word (Word32, )---type Importer f = FunPtr f -> f---foreign import ccall safe "dynamic" callShaper ::-   Importer (Ptr param -> Ptr shape -> IO Word32)--foreign import ccall safe "dynamic" callFill ::-   Importer (Ptr param -> Ptr shape -> Ptr am -> IO ())--materialize ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>-   String ->-   (core -> Exp sh) ->-   (core ->-    LLVM.Value (Ptr (MultiValueMemory.Struct sh)) ->-    LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->-    LLVM.CodeGenFunction () ()) ->-   Sym.Hull p core -> IO (p -> IO (Phys.Array sh a))-materialize name shape fill (Sym.Hull core create delete) = do-   (fsh, farr) <--      compile name $-      liftA2 (,)-         (Code.createFunction callShaper "shape" $-          \paramPtr resultPtr -> do-            param <- Memory.load paramPtr-            sh <- unExp $ shape $ core param-            MultiValueMemory.store sh resultPtr-            Shape.sizeCode sh >>= LLVM.ret)-         (Code.createFunction callFill "fill" $-          \paramPtr shapePtr bufferPtr -> do-            param <- Memory.load paramPtr-            fill (core param) shapePtr bufferPtr-            LLVM.ret ())--   return $ \p ->-      bracket (create p) (delete . fst) $ \(_ctx, param) ->-      alloca $ \shptr ->-      with param $ \paramPtr -> do-         let paramMVPtr = MultiValueMemory.castStructPtr paramPtr-         let shapeMVPtr = MultiValueMemory.castStructPtr shptr-         n <- fsh paramMVPtr shapeMVPtr-         fptr <- mallocForeignPtrArray (fromIntegral n)-         withForeignPtr fptr $-            farr paramMVPtr shapeMVPtr . MultiValueMemory.castStructPtr-         sh <- peek shptr-         return (Phys.Array sh fptr)---render ::-   (Shape.C sh, Shape.Index sh ~ ix,-    Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>-   Sym.Hull p (Core.Array sh a) -> IO (p -> IO (Phys.Array sh a))-render =-   materialize "render" Core.shape-      (\(Core.Array esh code) shapePtr bufferPtr -> do-         let step ix p = do-                flip Memory.store p =<< code ix-                A.advanceArrayElementPtr p-         sh <- Shape.load esh shapePtr-         void $ Shape.loop step sh bufferPtr)---data Scatter sh0 sh1 a =-   Scatter {-      scatterAccum :: Exp a -> Exp a -> Exp a,-      scatterInit :: Core.Array sh1 a,-      scatterMap :: Core.Array sh0 (Shape.Index sh1, a)-   }--scatter ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Storable sh1, MultiValueMemory.C sh1,-    Storable a, MultiValueMemory.C a) =>-   Sym.Hull p (Scatter sh0 sh1 a) -> IO (p -> IO (Phys.Array sh1 a))-scatter =-   materialize "scatter"-      (Core.shape . scatterInit)-      (\(Scatter accum arrInit arrMap) ->-         Priv.scatter accum arrInit arrMap)----data ScatterMaybe sh0 sh1 a =-   ScatterMaybe {-      scatterMaybeAccum :: Exp a -> Exp a -> Exp a,-      scatterMaybeInit :: Core.Array sh1 a,-      scatterMaybeMap :: Core.Array sh0 (Maybe (Shape.Index sh1, a))-   }--scatterMaybe ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Storable sh1, MultiValueMemory.C sh1,-    Storable a, MultiValueMemory.C a) =>-   Sym.Hull p (ScatterMaybe sh0 sh1 a) -> IO (p -> IO (Phys.Array sh1 a))-scatterMaybe =-   materialize "scatterMaybe"-      (Core.shape . scatterMaybeInit)-      (\(ScatterMaybe accum arrInit arrMap) ->-         Priv.scatterMaybe accum arrInit arrMap)---data MapAccumL sh n acc a b =-   MapAccumL {-      mapAccumLAccum :: Exp acc -> Exp a -> Exp (acc,b),-      mapAccumLInit :: Core.Array sh acc,-      mapAccumLMap :: Core.Array (sh, n) a-   }--mapAccumL ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    MultiValue.C acc,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>-   Sym.Hull p (MapAccumL sh n acc a b) -> IO (p -> IO (Phys.Array (sh,n) b))-mapAccumL =-   materialize "mapAccumL"-      (Core.shape . mapAccumLMap)-      (\(MapAccumL f arrInit arrData) -> Priv.mapAccumL f arrInit arrData)---data FoldOuterL n sh a b =-   FoldOuterL {-      foldOuterLAccum :: Exp a -> Exp b -> Exp a,-      foldOuterLInit :: Core.Array sh a,-      foldOuterLMap :: Core.Array (n,sh) b-   }---- FIXME: check correct size of array of initial values-foldOuterL ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    Storable a, MultiValueMemory.C a) =>-   Sym.Hull p (FoldOuterL n sh a b) -> IO (p -> IO (Phys.Array sh a))-foldOuterL =-   materialize "foldOuterL"-      (Core.shape . foldOuterLInit)-      (\(FoldOuterL f arrInit arrData) -> Priv.foldOuterL f arrInit arrData)
− src/Data/Array/Knead/Parameterized/Private.hs 
@@ -1,223 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-module Data.Array.Knead.Parameterized.Private where--import qualified Data.Array.Knead.Simple.Symbolic as Core--import qualified Data.Array.Knead.Parameter as Param-import qualified Data.Array.Knead.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, )--import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-import qualified LLVM.Extra.Multi.Value as MultiValue--import Foreign.Storable (Storable, )--import Control.Applicative (Applicative (pure, (<*>)), )--import Prelude hiding (id, map, zipWith, replicate, )----- in principle we could define Array in terms of Hull and Core.Array-data Array p sh a =-   forall parameter context.-   (Storable parameter, MultiValueMemory.C parameter) =>-   Array {-      core :: MultiValue.T parameter -> Core.Array sh a,-      createContext :: p -> IO (context, parameter),-      deleteContext :: context -> IO ()-   }--instance Core.C (Array p) where-   lift0 arr = Array (const arr) (createPlain (const ())) deletePlain-   lift1 f (Array arr create delete) = Array (f . arr) create delete-   lift2 f (Array arrA createA deleteA) (Array arrB createB deleteB) =-      Array-         (\p ->-            case MultiValue.unzip p of-               (paramA, paramB) -> f (arrA paramA) (arrB paramB))-         (combineCreate createA createB)-         (combineDelete deleteA deleteB)---(!) ::-   (Shape.C sh, Shape.Index sh ~ ix,-    Storable ix, MultiValueMemory.C ix,-    Shape.Scalar z) =>-   Array p sh a -> Param.T p ix -> Array p z a-(!) arr pix =-   runHull $-   mapHullWithExp-      (\ix carr -> Core.fromScalar $ carr Core.! ix)-      (expParam pix)-      (arrayHull arr)---fill ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>-   Param.T p sh -> Param.T p a -> Array p sh a-fill sh a =-   Shape.paramWith sh $ \getSh valueSh ->-   Param.withMulti a $ \getA valueA ->-   Array-      (\p ->-         case MultiValue.unzip p of-            (vsh, va) ->-               Core.fill (valueSh vsh) (Expr.lift0 $ valueA va))-      (createPlain $ \p -> (getSh p, getA p))-      deletePlain--gather ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, MultiValue.C a) =>-   Array p sh1 ix0 ->-   Array p sh0 a ->-   Array p sh1 a-gather = Core.gather---id ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh, Shape.Index sh ~ ix) =>-   Param.T p sh -> Array p sh ix-id sh =-   Shape.paramWith sh $ \getSh valueSh ->-   Array-      (Core.id . valueSh)-      (createPlain getSh)-      deletePlain--map ::-   (Shape.C sh, MultiValueMemory.C c, Storable 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, MultiValueMemory.C c, Storable 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,-    MultiValueMemory.C c, Storable 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,-    MultiValueMemory.C c, Storable 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 Core.fold1All--lift ::-   (Shape.C sh0, Shape.C sh1,-    MultiValueMemory.C c, Storable c) =>-   (f -> Core.Array sh0 a -> Core.Array sh1 b) ->-   (Exp c -> f) ->-   Param.T p c -> Array p sh0 a -> Array p sh1 b-lift g f c arr =-   runHull $-   mapHullWithExp-      (\cexp -> g (f cexp))-      (expParam c)-      (arrayHull arr)---data Hull p a =-   forall parameter context.-   (Storable parameter, MultiValueMemory.C parameter) =>-   Hull {-      hullCore :: MultiValue.T parameter -> a,-      hullCreateContext :: p -> IO (context, parameter),-      hullDeleteContext :: context -> IO ()-   }--instance Functor (Hull p) where-   fmap f (Hull arr create delete) = Hull (f . arr) create delete--instance Applicative (Hull p) where-   pure a = Hull (const a) (const $ return ((),())) return-   Hull arrA createA deleteA <*> Hull arrB createB deleteB =-      Hull-         (\p -> case MultiValue.unzip p of (a,b) -> arrA a $ arrB b)-         (combineCreate createA createB)-         (combineDelete deleteA deleteB)--{- |-Equivalent to @liftA2 f (expHull p)@ but saves us an empty context.--}-mapHullWithExp ::-   (Exp sl -> a -> b) ->-   Param.Tunnel p sl -> Hull p a -> Hull p b-mapHullWithExp f tunnel (Hull arr create delete) =-   case tunnel of-      Param.Tunnel getSl valueSl ->-         Hull-            (\p ->-               case MultiValue.unzip p of-                  (arrp, sl) -> f (Expr.lift0 $ valueSl sl) $ arr arrp)-            (\p -> do-               (ctx, param) <- create p-               return (ctx, (param, getSl p)))-            delete--expHull :: Param.Tunnel p sl -> Hull p (Exp sl)-expHull tunnel =-   case tunnel of-      Param.Tunnel getSl valueSl ->-         Hull-            (Expr.lift0 . valueSl)-            (\p -> return ((), getSl p))-            return--arrayHull :: Array p sh a -> Hull p (Core.Array sh a)-arrayHull (Array arr create delete) = Hull arr create delete--runHull :: Hull p (Core.Array sh a) -> Array p sh a-runHull (Hull arr create delete) = Array arr create delete--extendHull :: (q -> p) -> Hull p a -> Hull q a-extendHull f (Hull arr create delete) = Hull arr (create . f) delete----expParam ::-   (Storable a, MultiValueMemory.C a) => Param.T p a -> Param.Tunnel p a-expParam = Param.tunnel MultiValue.cons----createPlain :: (Monad m) => (p -> pl) -> p -> m ((), pl)-createPlain f p = return ((), f p)--deletePlain :: (Monad m) => () -> m ()-deletePlain () = return ()---combineCreate ::-   Monad m =>-   (p -> m (ctxA, paramA)) -> (p -> m (ctxB, paramB)) ->-   p -> m ((ctxA, ctxB), (paramA, paramB))-combineCreate createA createB p = do-   (ctxA, paramA) <- createA p-   (ctxB, paramB) <- createB p-   return ((ctxA, ctxB), (paramA, paramB))--combineDelete ::-   Monad m =>-   (ctxA -> m ()) -> (ctxB -> m ()) -> (ctxA, ctxB) -> m ()-combineDelete deleteA deleteB (ctxA, ctxB) = do-   deleteA ctxA-   deleteB ctxB---extendParameter ::-   (q -> p) -> Array p sh a -> Array q sh a-extendParameter f (Array arr create delete) =-   Array arr (create . f) delete
− src/Data/Array/Knead/Parameterized/Render.hs 
@@ -1,139 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{- |-Simplify running the @render@ function by handling passing of parameters.--}-module Data.Array.Knead.Parameterized.Render (-   run,-   Scatter(..),-   ScatterMaybe(..),-   MapAccumL(..),-   FoldOuterL(..),-   ) 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.Parameter as Param-import qualified Data.Array.Knead.Index.Nested.Shape as Shape-import Data.Array.Knead.Parameterized.PhysicalHull-         (Scatter, ScatterMaybe, MapAccumL, FoldOuterL)-import Data.Array.Knead.Expression (Exp, )--import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-import qualified LLVM.Extra.Multi.Value as MultiValue--import Foreign.Storable (Storable, )--import Control.Arrow (arr, )-import Control.Applicative (liftA2, liftA3, pure, (<*>), )--import Data.Tuple.HT (fst3, snd3, thd3, )---class C f where-   type Plain f-   build :: Sym.Hull p f -> IO (p -> Plain f)--instance-   (MultiValueMemory.C sh, Storable sh, Shape.C sh,-    MultiValueMemory.C a, Storable a) =>-      C (Core.Array sh a) where-   type Plain (Core.Array sh a) = IO (Phys.Array sh a)-   build = PhysHullP.render--instance-   (MultiValueMemory.C sh0, Storable sh0, Shape.C sh0,-    MultiValueMemory.C sh1, Storable sh1, Shape.C sh1,-    MultiValueMemory.C a, Storable a) =>-      C (Scatter sh0 sh1 a) where-   type Plain (Scatter sh0 sh1 a) = IO (Phys.Array sh1 a)-   build = PhysHullP.scatter--instance-   (MultiValueMemory.C sh0, Storable sh0, Shape.C sh0,-    MultiValueMemory.C sh1, Storable sh1, Shape.C sh1,-    MultiValueMemory.C a, Storable 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, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    MultiValue.C acc,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>-      C (MapAccumL sh n acc a b) where-   type Plain (MapAccumL sh n acc a b) = IO (Phys.Array (sh,n) b)-   build = PhysHullP.mapAccumL--instance-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>-      C (FoldOuterL n sh a b) where-   type Plain (FoldOuterL n sh a b) = IO (Phys.Array sh a)-   build = PhysHullP.foldOuterL---singleton :: Exp a -> Core.Array () a-singleton = Core.fromScalar--instance (MultiValueMemory.C a, Storable a) => C (Exp a) where-   type Plain (Exp a) = IO a-   build = PhysP.the . Sym.runHull . fmap singleton--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-   (MultiValueMemory.C sh, Storable sh, Shape.C sh, MultiValueMemory.C a) =>-      Argument (Core.Array sh a) where-   type PlainArg (Core.Array sh a) = Phys.Array sh a-   buildArg = Sym.arrayHull . PhysP.feed--instance (MultiValueMemory.C a, Storable 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 ::-   (Storable x, MultiValueMemory.C x,-    Shape.C sha, Storable sha, MultiValueMemory.C sha, MultiValueMemory.C a,-    Shape.C shb, Storable shb, MultiValueMemory.C shb, MultiValueMemory.C b,-    Shape.C shc, Storable shc, MultiValueMemory.C shc, MultiValueMemory.C c,-    Storable 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 
@@ -1,104 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeOperators #-}-module Data.Array.Knead.Parameterized.Slice (-   T,-   apply,-   Linear,-   passAny,-   pass,-   pick,-   extrude,-   (Core.$:.),-   ) where--import qualified Data.Array.Knead.Parameterized.Private as Priv-import Data.Array.Knead.Parameterized.Private (Array(Array), )--import qualified Data.Array.Knead.Simple.Slice as Slice-import qualified Data.Array.Knead.Simple.Private as Core--import qualified Data.Array.Knead.Index.Linear as Linear-import qualified Data.Array.Knead.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Parameter as Param-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, )-import Data.Array.Knead.Index.Linear ((:.), )--import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-import qualified LLVM.Extra.Multi.Value as MultiValue--import Foreign.Storable (Storable, )---{--This wrapper data type is pretty much the same as Parameterized.Array-but there seems to be no benefit from using the same data structure for it.--}-data T p sh0 sh1 =-   forall parameter context.-   (Storable parameter, MultiValueMemory.C parameter) =>-   Cons {-      _core :: MultiValue.T parameter -> Slice.T sh0 sh1,-      _createContext :: p -> IO (context, parameter),-      _deleteContext :: context -> IO ()-   }--apply ::-   (Shape.C sh0, Shape.C sh1, MultiValue.C a) =>-   T p sh0 sh1 ->-   Array p sh0 a ->-   Array p sh1 a-apply (Cons slice createSlice deleteSlice) (Array arr createArr deleteArr) =-   Array-      (\p ->-         case MultiValue.unzip p of-            (paramSlice, paramArr) ->-               Slice.apply (slice paramSlice) (arr paramArr))-      (Priv.combineCreate createSlice createArr)-      (Priv.combineDelete deleteSlice deleteArr)---type Linear p sh0 sh1 = T p (Linear.Shape sh0) (Linear.Shape sh1)---passAny :: Linear p sh sh-passAny =-   Cons (const Slice.passAny) (Priv.createPlain $ const ()) Priv.deletePlain--pass ::-   Linear p sh0 sh1 ->-   Linear p (sh0:.i) (sh1:.i)-pass (Cons slice create delete) = Cons (Slice.pass . slice) create delete--pick ::-   (MultiValueMemory.C i, Storable i) =>-   Param.T p i ->-   Linear p sh0 sh1 ->-   Linear p (sh0:.i) sh1-pick = lift Slice.pick--extrude ::-   (MultiValueMemory.C i, Storable i) =>-   Param.T p i ->-   Linear p sh0 sh1 ->-   Linear p sh0 (sh1:.i)-extrude = lift Slice.extrude--lift ::-   (MultiValueMemory.C i, Storable i) =>-   (Exp i -> Slice.Linear sh0 sh1 -> Slice.Linear sh2 sh3) ->-   Param.T p i ->-   Linear p sh0 sh1 -> Linear p sh2 sh3-lift f i (Cons slice create delete) =-   Param.withMulti i $ \getI valueI ->-   Cons-      (\p ->-         case MultiValue.unzip p of-            (slicep, ip) ->-               f (Expr.lift0 (valueI ip)) (slice slicep))-      (\p -> do-         (ctx, param) <- create p-         return (ctx, (param, getI p)))-      delete--instance Core.Process (T p sh0 sh1) where
− src/Data/Array/Knead/Parameterized/Symbolic.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE GADTs #-}-module Data.Array.Knead.Parameterized.Symbolic (-   Array,-   Exp,-   Sym.extendParameter,-   withExp,-   withExp2,-   withExp3,-   (Sym.!),-   Sym.fill,-   gather,-   backpermute,-   Sym.id,-   Sym.map,-   zipWith,-   Sym.fold1,-   Sym.fold1All,-   ) where--import qualified Data.Array.Knead.Parameterized.Private as Sym-import qualified Data.Array.Knead.Simple.Symbolic as Core-import Data.Array.Knead.Parameterized.Private (Array, gather, )--import qualified Data.Array.Knead.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Parameter as Param-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, )--import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-import qualified LLVM.Extra.Multi.Value as MultiValue--import Foreign.Storable (Storable, )--import Control.Applicative ((<*>), )--import Prelude (uncurry, ($), (.), )---{--fromScalar ::-   (Storable a, MultiValueMemory.C a, MultiValue.C a) =>-   Param.T p a -> Array p Z a-fromScalar = Sym.fill (return Z)--}---backpermute ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Storable sh1, MultiValueMemory.C sh1,-    MultiValue.C a) =>-   Param.T p sh1 ->-   (Exp ix1 -> Exp ix0) ->-   Array p sh0 a ->-   Array p sh1 a-backpermute sh1 f = gather (Core.map f (Sym.id sh1))---zipWith ::-   (Shape.C sh, MultiValueMemory.C d, Storable d) =>-   (Exp d -> Exp a -> Exp b -> Exp c) ->-   Param.T p d -> Array p sh a -> Array p sh b -> Array p sh c-zipWith f d a b =-   Sym.map (\di ab -> uncurry (f di) $ Expr.unzip ab) d $ Core.zip a b---withExp ::-   (Storable x, MultiValueMemory.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 ::-   (Storable x, MultiValueMemory.C x) =>-   (Exp x -> Core.Array sha a -> Core.Array shb b -> Core.Array shc c) ->-   Param.T p x -> Array p sha a -> Array p shb b -> Array p shc c-withExp2 f x a b =-   Sym.runHull $-   Sym.mapHullWithExp f (Sym.expParam x) (Sym.arrayHull a)-     <*> Sym.arrayHull b--withExp3 ::-   (Storable x, MultiValueMemory.C x) =>-   (Exp x -> Core.Array sha a ->-    Core.Array shb b -> Core.Array shc c -> Core.Array shd d) ->-   Param.T p x -> Array p sha a ->-   Array p shb b -> Array p shc c -> Array p shd d-withExp3 f x a b c =-   Sym.runHull $-   Sym.mapHullWithExp f (Sym.expParam x) (Sym.arrayHull a)-     <*> Sym.arrayHull b-     <*> Sym.arrayHull c
+ src/Data/Array/Knead/Shape.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module Data.Array.Knead.Shape (+   C(..), Index,+   Size,+   value,+   paramWith,+   load,+   intersect,+   offset,++   ZeroBased(ZeroBased), zeroBased, zeroBasedSize,++   Range(Range), range, rangeFrom, rangeTo,+   Shifted(Shifted), shifted, shiftedOffset, shiftedSize,+   Cyclic(Cyclic), cyclic, cyclicSize,++   Enumeration(Enumeration), EnumBounded(..),++   Scalar(..),+   Sequence(..),+   ) where++import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Shape.Orphan+         (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), Cyclic,+          Enumeration(Enumeration))+import Data.Ix (Ix)++import qualified LLVM.DSL.Parameter as Param++import qualified LLVM.Extra.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value as NiceValue+import qualified LLVM.Extra.Nice.Iterator as IterNV+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Iterator as Iter+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Nice.Value (atom)++import qualified LLVM.Core as LLVM++import qualified Data.Enum.Storable as Enum+import Data.Tagged (Tagged)+import Data.Tuple.HT (mapSnd)+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int (Int8, Int16, Int32, Int64)++import qualified Control.Monad.HT as Monad+import Control.Applicative ((<$>))++import Prelude2010+import Prelude ()+++type Size = Word++value :: (C sh, Expr.Value val) => sh -> val sh+value = Expr.lift0 . NiceValue.cons++paramWith ::+   (Marshal.C b) =>+   Param.T p b ->+   (forall parameters.+    (Marshal.C parameters) =>+    (p -> parameters) ->+    (forall val. (Expr.Value val) =>+     NiceValue.T parameters -> val b) ->+    a) ->+   a+paramWith p f =+   Param.withNice p (\get val -> f get (Expr.lift0 . val))++load ::+   (Marshal.C sh) =>+   f sh -> LLVM.Value (LLVM.Ptr (Marshal.Struct sh)) ->+   LLVM.CodeGenFunction r (NiceValue.T sh)+load _ = Memory.load++intersect :: (C sh) => Exp sh -> Exp sh -> Exp sh+intersect = Expr.liftM2 intersectCode++offset ::+   (C sh) =>+   NiceValue.T sh -> NiceValue.T (Index sh) ->+   LLVM.CodeGenFunction r (LLVM.Value Size)+offset sh ix = ($ ix) . snd =<< sizeOffset sh++class (NiceValue.C sh, NiceValue.C (Index sh), Shape.Indexed sh) => C sh where+   {-+   It would be better to restrict zipWith to matching shapes+   and turn shape intersection into a bound check.+   -}+   intersectCode ::+      NiceValue.T sh -> NiceValue.T sh ->+      LLVM.CodeGenFunction r (NiceValue.T sh)+   size :: NiceValue.T sh -> LLVM.CodeGenFunction r (LLVM.Value Size)+   {- |+   Result is @(size, offset)@.+   @size@ must equal the result of 'size'.+   We use this for sharing intermediate results.+   -}+   sizeOffset ::+      (Index sh ~ ix) =>+      NiceValue.T sh ->+      LLVM.CodeGenFunction r+         (LLVM.Value Size,+          NiceValue.T ix -> LLVM.CodeGenFunction r (LLVM.Value Size))+   iterator :: (Index sh ~ ix) => NiceValue.T sh -> Iter.T r (NiceValue.T ix)+   loop ::+      (Index sh ~ ix, Tuple.Phi state) =>+      (NiceValue.T ix -> state -> LLVM.CodeGenFunction r state) ->+      NiceValue.T sh -> state -> LLVM.CodeGenFunction r state+   loop f sh = Iter.mapState_ f (iterator sh)+++instance C () where+   intersectCode _ _ = return $ NiceValue.cons ()+   size _ = return A.one+   sizeOffset _ = return (A.one, \_ -> return A.zero)+   iterator = Iter.singleton+   loop = id+++class C sh => Scalar sh where+   scalar :: (Expr.Value val) => val sh+   zeroIndex :: (Expr.Value val) => f sh -> val (Index sh)++instance Scalar () where+   scalar = Expr.lift0 $ NiceValue.Cons ()+   zeroIndex _ = Expr.lift0 $ NiceValue.Cons ()+++class+   (C sh,+    NiceValue.IntegerConstant (Index sh),+    NiceValue.Additive (Index sh)) =>+      Sequence sh where+   sequenceShapeFromIndex ::+      NiceValue.T (Index sh) -> LLVM.CodeGenFunction r (NiceValue.T sh)+++class+   (NiceValue.Additive n, NiceValue.Real n, NiceValue.IntegerConstant n) =>+      ToSize n where+   toSize :: NiceValue.T n -> LLVM.CodeGenFunction r (LLVM.Value Size)++instance ToSize Word8  where toSize (NiceValue.Cons n) = LLVM.ext n+instance ToSize Word16 where toSize (NiceValue.Cons n) = LLVM.ext n+instance ToSize Word32 where toSize (NiceValue.Cons n) = LLVM.adapt n+instance ToSize Word64 where toSize (NiceValue.Cons n) = LLVM.adapt n+instance ToSize Word   where toSize (NiceValue.Cons n) = LLVM.adapt n+instance ToSize Int8  where toSize (NiceValue.Cons n) = LLVM.zext n+instance ToSize Int16 where toSize (NiceValue.Cons n) = LLVM.zext n+instance ToSize Int32 where toSize (NiceValue.Cons n) = LLVM.zadapt n+instance ToSize Int64 where toSize (NiceValue.Cons n) = LLVM.zadapt n+instance ToSize Int   where toSize (NiceValue.Cons n) = LLVM.zadapt n+++{- |+Array dimensions and indexes cannot be negative,+but computations in indices may temporarily yield negative values+or we want to add negative values to indices.++So maybe, we would better have type Index (ZeroBased Word64) = Int64.+This is not possible.+Maybe we need an additional ZeroBased type for unsigned array sizes.+-}+instance+      (Integral n, ToSize n, NiceValue.Comparison n) => C (ZeroBased n) where+   intersectCode sha shb =+      zeroBased <$> NiceValue.min (zeroBasedSize sha) (zeroBasedSize shb)+   size = toSize . zeroBasedSize+   sizeOffset sh = Monad.lift2 (,) (toSize $ zeroBasedSize sh) (return toSize)+   iterator sh =+      IterNV.take (zeroBasedSize sh) $+      Iter.iterate NiceValue.inc NiceValue.zero++instance+   (Integral n, ToSize n, NiceValue.Comparison n) =>+      Sequence (ZeroBased n) where+   sequenceShapeFromIndex = return . zeroBased+++rangeSize ::+   (ToSize n) =>+   Range (NiceValue.T n) -> LLVM.CodeGenFunction r (LLVM.Value Size)+rangeSize (Range from to) =+   toSize =<< NiceValue.inc =<< NiceValue.sub to from+++rangeFrom :: (Expr.Value val) => val (Range n) -> val n+rangeFrom = Expr.lift1 $ Shape.rangeFrom . unzipRange++rangeTo :: (Expr.Value val) => val (Range n) -> val n+rangeTo = Expr.lift1 $ Shape.rangeTo . unzipRange++range :: (Expr.Value val) => val n -> val n -> val (Range n)+range =+   Expr.lift2 $+      \(NiceValue.Cons from) (NiceValue.Cons to) ->+         NiceValue.Cons (Range from to)++instance (Ix n, ToSize n, NiceValue.Comparison n) => C (Range n) where+   intersectCode =+      NiceValue.modifyF2 (singletonRange atom) (singletonRange atom) $+            \(Range fromN toN) (Range fromM toM) ->+         Monad.lift2 Range (NiceValue.max fromN fromM) (NiceValue.min toN toM)+   size = rangeSize . unzipRange+   sizeOffset rngValue =+      case unzipRange rngValue of+         rng@(Range from _to) ->+            Monad.lift2 (,) (rangeSize rng)+               (return $ \i -> toSize =<< NiceValue.sub i from)+   iterator rngValue =+      case NiceValue.decompose (singletonRange atom) rngValue of+         Range from to ->+            IterNV.takeWhile (NiceValue.cmp LLVM.CmpGE to) $+            Iter.iterate NiceValue.inc from++++shiftedOffset :: (Expr.Value val) => val (Shifted n) -> val n+shiftedOffset = Expr.lift1 $ Shape.shiftedOffset . unzipShifted++shiftedSize :: (Expr.Value val) => val (Shifted n) -> val n+shiftedSize = Expr.lift1 $ Shape.shiftedSize . unzipShifted++shifted :: (Expr.Value val) => val n -> val n -> val (Shifted n)+shifted =+   Expr.lift2 $+      \(NiceValue.Cons from) (NiceValue.Cons to) ->+         NiceValue.Cons (Shifted from to)+++instance (Integral n, ToSize n, NiceValue.Comparison n) => C (Shifted n) where+   intersectCode =+      NiceValue.modifyF2 (singletonShifted atom) (singletonShifted atom) $+            \(Shifted startN lenN) (Shifted startM lenM) -> do+         start <- NiceValue.max startN startM+         endN <- NiceValue.add startN lenN+         endM <- NiceValue.add startM lenM+         end <- NiceValue.min endN endM+         Shifted start <$> NiceValue.sub end start+   size = toSize . shiftedSize+   sizeOffset shapeValue =+      case unzipShifted shapeValue of+         Shifted start len ->+            Monad.lift2 (,) (toSize len)+               (return $ \i -> toSize =<< NiceValue.sub i start)+   iterator rngValue =+      case NiceValue.decompose (singletonShifted atom) rngValue of+         Shifted from len ->+            IterNV.take len $ Iter.iterate NiceValue.inc from+++instance+      (Integral n, ToSize n, NiceValue.Comparison n) => C (Cyclic n) where+   intersectCode sha shb =+      cyclic <$> NiceValue.min (cyclicSize sha) (cyclicSize shb)+   size = toSize . cyclicSize+   sizeOffset sh = Monad.lift2 (,) (toSize $ cyclicSize sh) (return toSize)+   iterator sh =+      IterNV.take (cyclicSize sh) $+      Iter.iterate NiceValue.inc NiceValue.zero+++class (IterNV.Enum enum, NiceValue.Bounded enum) => EnumBounded enum where+   enumOffset :: NiceValue.T enum -> LLVM.CodeGenFunction r (LLVM.Value Size)++instance+   (ToSize w, NiceValue.Additive w,+    LLVM.IsInteger w, SoV.IntegerConstant w, Num w,+    NiceValue.Repr w ~ LLVM.Value w,+    LLVM.CmpRet w, LLVM.IsPrimitive w,+    Enum e, Bounded e) =>+      EnumBounded (Enum.T w e) where+   enumOffset ix =+      toSize =<<+      NiceValue.sub+         (NiceValue.fromEnum ix)+         (NiceValue.fromEnum $ NiceValue.minBound `asTypeOf` ix)++instance+      (Enum enum, Bounded enum, EnumBounded enum) => C (Enumeration enum) where+   intersectCode _sha shb = return shb+   size = return . A.fromInteger' . toInteger . Shape.size . plainEnumeration+   sizeOffset sh = do+      sz <- size sh+      return (sz, enumOffset)+   iterator _ = IterNV.enumFromTo NiceValue.minBound NiceValue.maxBound++plainEnumeration :: val (Enumeration enum) -> Enumeration enum+plainEnumeration _ = Enumeration+++instance (C sh) => C (Tagged tag sh) where+   intersectCode = NiceValue.liftTaggedM2 intersectCode+   size = size . NiceValue.untag+   sizeOffset =+      fmap (mapSnd (. NiceValue.untag)) . sizeOffset . NiceValue.untag+   iterator = fmap NiceValue.tag . iterator . NiceValue.untag+++instance (C n, C m) => C (n,m) where+   intersectCode a b =+      case (NiceValue.unzip a, NiceValue.unzip b) of+         ((an,am), (bn,bm)) ->+            Monad.lift2 NiceValue.zip+               (intersectCode an bn)+               (intersectCode am bm)+   size nm =+      case NiceValue.unzip nm of+         (n,m) -> Monad.liftJoin2 A.mul (size n) (size m)+   sizeOffset nm =+      case NiceValue.unzip nm of+         (n,m) -> do+            (ns, iOffset) <- sizeOffset n+            (ms, jOffset) <- sizeOffset m+            sz <- A.mul ns ms+            return+               (sz,+                \ij ->+                  case NiceValue.unzip ij of+                     (i,j) -> do+                        il <- iOffset i+                        jl <- jOffset j+                        A.add jl =<< A.mul ms il)+   iterator nm =+      case NiceValue.unzip nm of+         (n,m) ->+            uncurry NiceValue.zip <$>+            Iter.cartesian (iterator n) (iterator m)+   loop code nm =+      case NiceValue.unzip nm of+         (n,m) -> loop (\i -> loop (\j -> code (NiceValue.zip i j)) m) n++instance (C n, C m, C l) => C (n,m,l) where+   intersectCode a b =+      case (NiceValue.unzip3 a, NiceValue.unzip3 b) of+         ((ai,aj,ak), (bi,bj,bk)) ->+            Monad.lift3 NiceValue.zip3+               (intersectCode ai bi)+               (intersectCode aj bj)+               (intersectCode ak bk)+   size nml =+      case NiceValue.unzip3 nml of+         (n,m,l) ->+            Monad.liftJoin2 A.mul (size n) $+            Monad.liftJoin2 A.mul (size m) (size l)+   sizeOffset nml =+      case NiceValue.unzip3 nml of+         (n,m,l) -> do+            (ns, iOffset) <- sizeOffset n+            (ms, jOffset) <- sizeOffset m+            (ls, kOffset) <- sizeOffset l+            sz <- A.mul ns =<< A.mul ms ls+            return+               (sz,+                \ijk ->+                  case NiceValue.unzip3 ijk of+                     (i,j,k) -> do+                        il <- iOffset i+                        jl <- jOffset j+                        kl <- kOffset k+                        A.add kl =<< A.mul ls =<< A.add jl =<< A.mul ms il)+   iterator nml =+      case NiceValue.unzip3 nml of+         (n,m,l) ->+            fmap (\(a,(b,c)) -> NiceValue.zip3 a b c) $+            Iter.cartesian (iterator n) $+            Iter.cartesian (iterator m) (iterator l)+   loop code nml =+      case NiceValue.unzip3 nml of+         (n,m,l) ->+            loop (\i -> loop (\j -> loop (\k ->+               code (NiceValue.zip3 i j k))+            l) m) n
+ src/Data/Array/Knead/Shape/Cubic.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module Data.Array.Knead.Shape.Cubic (+   constant,+   paramWith,+   tunnel,++   T(..),+   Z(Z), z,+   (:.)((:.)),+   Shape,+   Index,+   cons, (#:.),+   head,+   tail,+   switchR,+   ) where++import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Knead.Shape.Cubic.Int as Index++import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Expression (Exp, )++import qualified Data.Array.Comfort.Shape as ComfortShape+import Data.Array.Comfort.Shape (ZeroBased(ZeroBased))++import qualified LLVM.DSL.Parameter as Param++import qualified LLVM.Extra.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value as NiceValue+import qualified LLVM.Extra.Nice.Iterator as IterNV+import qualified LLVM.Extra.Iterator as Iter+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Control as C+import LLVM.Extra.Nice.Value (Atom)++import qualified LLVM.Core as LLVM++import qualified Foreign.Storable as St+import Foreign.Storable.FixedArray (sizeOfArray, )+import Foreign.Ptr (castPtr, )++import qualified Type.Data.Num.Decimal as Dec+import qualified Type.Data.Num.Unary as Unary+import Type.Base.Proxy (Proxy(Proxy))++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.FixedLength as FixedLength+import Data.FixedLength ((!:))++import Control.Monad (liftM2, )+import Control.Applicative (pure, (<$>), )++import Prelude hiding (min, head, tail, )+++newtype T tag rank = Cons {decons :: FixedLength.T rank Index.Int}++data ShapeTag+data IndexTag++type Shape = T ShapeTag+type Index = T IndexTag+++paramWith ::+   (Unary.Natural rank,+    Dec.Natural (Dec.FromUnary rank),+    Dec.Natural (Dec.FromUnary rank Dec.:*: LLVM.SizeOf Shape.Size)) =>+   Param.T p (T tag rank) ->+   (forall parameters.+    (Marshal.C parameters) =>+    (p -> parameters) ->+    (forall val. (Expr.Value val) =>+     NiceValue.T parameters -> val (T tag rank)) ->+    a) ->+   a+paramWith p f =+   case tunnel p of+      Param.Tunnel get val -> f get (Expr.lift0 . val)++tunnel ::+   (Unary.Natural rank,+    Dec.Natural (Dec.FromUnary rank),+    Dec.Natural (Dec.FromUnary rank Dec.:*: LLVM.SizeOf Shape.Size)) =>+   Param.T p (T tag rank) -> Param.Tunnel p (T tag rank)+tunnel p = Param.tunnel NiceValue.cons p+++data Z = Z+   deriving (Eq, Ord, Read, Show)+++infixl 3 :., #:.++data tail :. head = !tail :. !head+   deriving (Eq, Ord, Read, Show)+++(#:.) ::+   (Expr.Value val) =>+   val (T tag rank) -> val Index.Int -> val (T tag (Unary.Succ rank))+(#:.) = cons++cons ::+   (Expr.Value val) =>+   val (T tag rank) -> val Index.Int -> val (T tag (Unary.Succ rank))+cons =+   Expr.lift2 $+      \(NiceValue.Cons t) (NiceValue.Cons h) -> NiceValue.Cons (h!:t)++z :: (Expr.Value val) => val (T tag Unary.Zero)+z = Expr.lift0 $ NiceValue.Cons FixedLength.end++head ::+   (Expr.Value val, Unary.Natural rank) =>+   val (T tag (Unary.Succ rank)) -> val Index.Int+head =+   Expr.lift1 $ \(NiceValue.Cons sh) -> NiceValue.Cons $ FixedLength.head sh++tail ::+   (Expr.Value val, Unary.Natural rank) =>+   val (T tag (Unary.Succ rank)) -> val (T tag rank)+tail =+   Expr.lift1 $ \(NiceValue.Cons sh) -> NiceValue.Cons $ FixedLength.tail sh++switchR ::+   (Unary.Natural rank) =>+   Expr.Value val =>+   (val (T tag rank) -> val Index.Int -> a) ->+   val (T tag (Unary.Succ rank)) -> a+switchR f ix = f (tail ix) (head ix)+++rank :: T tag rank -> Proxy rank+rank (Cons _) = Proxy+++instance (tag ~ ShapeTag, rank ~ Unary.Zero) => Shape.Scalar (T tag rank) where+   scalar = Expr.lift0 $ NiceValue.Cons FixedLength.end+   zeroIndex _ = Expr.lift0 $ NiceValue.Cons FixedLength.end+++type family AtomRank sh+type instance AtomRank (Atom (T tag rank)) = rank+type instance AtomRank (sh:.s) = Unary.Succ (AtomRank s)++type family AtomTag sh+type instance AtomTag (Atom (T tag rank)) = tag+type instance AtomTag (sh:.s) = AtomTag sh++type instance NiceValue.PatternTuple (sh:.s) =+   T (AtomTag sh) (Unary.Succ (AtomRank sh))++type instance NiceValue.Decomposed f (sh:.s) =+   NiceValue.Decomposed f sh :. f Index.Int++instance+   (Expr.Decompose sh, Expr.Decompose s,+    NiceValue.Decomposed Exp s ~ Exp Index.Int,+    NiceValue.PatternTuple s ~ Index.Int,+    NiceValue.PatternTuple sh ~ T (AtomTag sh) (AtomRank sh),+    Unary.Natural (AtomRank sh)) =>+      Expr.Decompose (sh :. s) where+   decompose (psh:.ps) x =+      Expr.decompose psh (tail x) :. Expr.decompose ps (head x)+++type family Rank sh+type instance Rank (T tag rank) = rank++type family Tag sh+type instance Tag (T tag rank) = tag++instance+   (Expr.Compose sh,+    Expr.Composed sh ~ T (Tag (Expr.Composed sh)) (Rank (Expr.Composed sh)),+    Expr.Compose s,+    Expr.Composed s ~ Index.Int) =>+      Expr.Compose (sh :. s) where+   type Composed (sh :. s) =+            T (Tag (Expr.Composed sh)) (Unary.Succ (Rank (Expr.Composed sh)))+   compose (sh :. s) = cons (Expr.compose sh) (Expr.compose s)+++instance (Unary.Natural rank) => St.Storable (T tag rank) where+   sizeOf sh = sizeOfArray (Unary.integralFromProxy $ rank sh) (0::Shape.Size)+   alignment (Cons _sh) = St.alignment (0::Shape.Size)+   poke ptr = St.poke (castPtr ptr) . fmap (\(Index.Int i) -> i) . decons+   peek = fmap (Cons . fmap Index.Int) . St.peek . castPtr++instance+   (Unary.Natural rank,+    Dec.Natural (Dec.FromUnary rank),+    Dec.Natural (Dec.FromUnary rank Dec.:*: LLVM.SizeOf Shape.Size)) =>+      Marshal.C (T tag rank) where+   pack = LLVM.Array . map Marshal.pack . Fold.toList . decons+   unpack (LLVM.Array sh) = Cons $ toFixedList $ map Marshal.unpack sh++toFixedList :: (Unary.Natural n) => [a] -> FixedLength.T n a+toFixedList xs = snd $ Trav.mapAccumL (\(y:ys) () -> (ys,y)) xs (pure ())+++instance (Unary.Natural rank) => NiceValue.C (T tag rank) where+   type Repr (T tag rank) = FixedLength.T rank (NiceValue.Repr Index.Int)+   cons = NiceValue.Cons . fmap (\(Index.Int i) -> LLVM.valueOf i) . decons+   undef = constant $ NiceValue.undef+   zero = constant $ NiceValue.zero+   addPhi bb (NiceValue.Cons a) (NiceValue.Cons b) =+      Tuple.addPhiFoldable bb a b+   phi bb (NiceValue.Cons a) =+      fmap NiceValue.Cons . Tuple.phiTraversable bb $ a++constant ::+   (Unary.Natural rank) => NiceValue.T Index.Int -> NiceValue.T (T tag rank)+constant (NiceValue.Cons x) = NiceValue.Cons $ pure x++instance+   (tag ~ ShapeTag, Unary.Natural rank) =>+      ComfortShape.C (T tag rank) where+   size = Fold.product . fmap (ComfortShape.size . shapeFromInt) . decons++instance+   (tag ~ ShapeTag, Unary.Natural rank) =>+      ComfortShape.Indexed (T tag rank) where+   type Index (T tag rank) = Index rank+   indices (Cons ix) =+      map (Cons . fmap Index.Int) $+      Trav.mapM (ComfortShape.indices . shapeFromInt) ix+   inBounds (Cons sh) (Cons ix) =+      Fold.and $+      FixedLength.zipWith ComfortShape.inBounds+         (shapeFromInt <$> sh) (indexFromInt <$> ix)+   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+shapeFromInt (Index.Int i) = ZeroBased i++indexFromInt :: Index.Int -> Shape.Size+indexFromInt (Index.Int i) = i+++instance (tag ~ ShapeTag, Unary.Natural rank) => Shape.C (T tag rank) where+   size (NiceValue.Cons sh) = Fold.foldlM A.mul A.one sh+   intersectCode (NiceValue.Cons sh0) (NiceValue.Cons sh1) =+      fmap NiceValue.Cons $ Trav.sequence $ FixedLength.zipWith A.min sh0 sh1+   sizeOffset sh =+      -- would a joint implementation be more efficient?+      liftM2 (,) (Shape.size sh) (return $ offsetCode sh)+   iterator = iterator+   loop = loop+++offsetCode ::+   (Unary.Natural rank) =>+   NiceValue.T (Shape rank) -> NiceValue.T (Index rank) ->+   LLVM.CodeGenFunction r (LLVM.Value Shape.Size)+offsetCode (NiceValue.Cons sh) (NiceValue.Cons ix) =+   Fold.foldlM (\off (s,i) -> A.mul off s >>= A.add i) A.zero $+   FixedLength.zipWith (,) sh ix+++newtype Iterator r rank =+   Iterator {+      runIterator ::+         NiceValue.T (Shape rank) -> Iter.T r (NiceValue.T (Index rank))+   }++iterator ::+   (Unary.Natural rank) =>+   NiceValue.T (Shape rank) -> Iter.T r (NiceValue.T (Index rank))+iterator =+   runIterator $+   Unary.switchNat+      (Iterator $ \ _z -> Iter.singleton z)+      (Iterator $ switchR $ \sh n ->+       fmap (\(ix,i) -> ix#:.i) $+       Iter.cartesian+         (iterator sh)+         (IterNV.takeWhile (NiceValue.cmp LLVM.CmpGT n) $+          Iter.iterate NiceValue.inc NiceValue.zero))+++newtype Loop r state rank =+   Loop {+      runLoop ::+         (NiceValue.T (Index rank) ->+          state ->+          LLVM.CodeGenFunction r state) ->+         NiceValue.T (Shape rank) ->+         state ->+         LLVM.CodeGenFunction r state+   }++loop ::+   (Unary.Natural rank, Tuple.Phi state) =>+   (NiceValue.T (Index rank) ->+    state ->+    LLVM.CodeGenFunction r state) ->+   NiceValue.T (Shape rank) ->+   state ->+   LLVM.CodeGenFunction r state+loop =+   runLoop $+   Unary.switchNat+      (Loop $ \code _z -> code z)+      (Loop $ \code -> switchR $ \sh (NiceValue.Cons n) ->+         loop+            (\ix ptrStart ->+               fmap fst $+               C.fixedLengthLoop n (ptrStart, A.zero) $ \(ptr, k) ->+                  liftM2 (,)+                     (code (ix #:. NiceValue.Cons k) ptr)+                     (A.inc k))+            sh)
+ src/Data/Array/Knead/Shape/Cubic/Int.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Array.Knead.Shape.Cubic.Int (+   Single(..),+   Int(Int), cons, decons,+   ) where++import qualified Data.Array.Knead.Expression as Expr++import qualified LLVM.Extra.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value as NiceValue+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM++import Data.Word (Word)++import Prelude hiding (Int, head, tail, )+++newtype Int = Int Word++cons :: (Expr.Value val) => val Word -> val Int+cons = Expr.lift1 $ \(NiceValue.Cons x) -> NiceValue.Cons x++decons :: (Expr.Value val) => val Int -> val Word+decons = Expr.lift1 $ \(NiceValue.Cons x) -> NiceValue.Cons x+++class Single ix where+   switchSingle :: f Int -> f ix++instance Single Int where+   switchSingle x = x+++instance NiceValue.C Int where+   type Repr Int = LLVM.Value Word+   cons (Int x) = NiceValue.consPrimitive x+   undef = NiceValue.undefPrimitive+   zero = NiceValue.zeroPrimitive+   phi = NiceValue.phiPrimitive+   addPhi = NiceValue.addPhiPrimitive++instance NiceValue.Additive Int where+   add = NiceValue.liftM2 A.add+   sub = NiceValue.liftM2 A.sub+   neg = NiceValue.liftM A.neg++instance NiceValue.PseudoRing Int where+   mul = NiceValue.liftM2 A.mul++instance NiceValue.Real Int where+   min = NiceValue.liftM2 A.min+   max = NiceValue.liftM2 A.max+   abs = NiceValue.liftM A.abs+   signum = NiceValue.liftM A.signum++instance NiceValue.IntegerConstant Int where+   fromInteger' = cons . A.fromInteger'++instance NiceValue.Comparison Int where+   cmp mode = NiceValue.liftM2 $ A.cmp mode+++instance Marshal.C Int where+   pack (Int i) = i+   unpack = Int
+ src/Data/Array/Knead/Shape/Orphan.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Array.Knead.Shape.Orphan where++import qualified Data.Array.Knead.Expression as Expr++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.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value as NiceValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Tuple as Tuple++import qualified Control.Monad.HT as Monad+import Control.Applicative ((<$>))++import Prelude2010+import Prelude ()++++unzipZeroBased :: NiceValue.T (ZeroBased n) -> ZeroBased (NiceValue.T n)+unzipZeroBased (NiceValue.Cons (ZeroBased n)) = ZeroBased (NiceValue.Cons n)++zeroBasedSize :: (Expr.Value val) => val (ZeroBased n) -> val n+zeroBasedSize = Expr.lift1 $ Shape.zeroBasedSize . unzipZeroBased++zeroBased :: (Expr.Value val) => val n -> val (ZeroBased n)+zeroBased = Expr.lift1 $ \(NiceValue.Cons n) -> NiceValue.Cons (ZeroBased n)++instance (Tuple.Undefined n) => Tuple.Undefined (ZeroBased n) where+   undef = ZeroBased Tuple.undef++instance (Tuple.Phi n) => Tuple.Phi (ZeroBased n) where+   phi bb = fmap ZeroBased . Tuple.phi bb . Shape.zeroBasedSize+   addPhi bb (Shape.ZeroBased a) (Shape.ZeroBased b) = Tuple.addPhi bb a b++instance (Tuple.Value n) => Tuple.Value (ZeroBased n) where+   type ValueOf (ZeroBased n) = ZeroBased (Tuple.ValueOf n)+   valueOf (ZeroBased n) = ZeroBased $ Tuple.valueOf n++instance (NiceValue.C n) => NiceValue.C (ZeroBased n) where+   type Repr (ZeroBased n) = ZeroBased (NiceValue.Repr n)+   cons (ZeroBased n) = zeroBased (NiceValue.cons n)+   undef = zeroBased NiceValue.undef+   zero = zeroBased NiceValue.zero+   phi bb = Monad.lift zeroBased . NiceValue.phi bb . zeroBasedSize+   addPhi bb a b = NiceValue.addPhi bb (zeroBasedSize a) (zeroBasedSize b)++type instance+   NiceValue.Decomposed f (ZeroBased pn) =+      ZeroBased (NiceValue.Decomposed f pn)+type instance+   NiceValue.PatternTuple (ZeroBased pn) =+      ZeroBased (NiceValue.PatternTuple pn)++instance (NiceValue.Compose n) => NiceValue.Compose (ZeroBased n) where+   type Composed (ZeroBased n) = ZeroBased (NiceValue.Composed n)+   compose (ZeroBased n) = zeroBased (NiceValue.compose n)++instance (NiceValue.Decompose pn) => NiceValue.Decompose (ZeroBased pn) where+   decompose (ZeroBased p) sh =+      NiceValue.decompose p <$> unzipZeroBased sh++instance (Expr.Compose n) => Expr.Compose (ZeroBased n) where+   type Composed (ZeroBased n) = ZeroBased (Expr.Composed n)+   compose (ZeroBased n) = Expr.lift1 zeroBased (Expr.compose n)++instance (Expr.Decompose pn) => Expr.Decompose (ZeroBased pn) where+   decompose (ZeroBased p) = ZeroBased . Expr.decompose p . zeroBasedSize++instance (Memory.C n) => Memory.C (ZeroBased n) where+   type Struct (ZeroBased n) = Memory.Struct n+   compose = Memory.compose . Shape.zeroBasedSize+   decompose = fmap ZeroBased . Memory.decompose++instance (Marshal.C n) => Marshal.C (ZeroBased n) where+   pack = Marshal.pack . Shape.zeroBasedSize+   unpack = Shape.ZeroBased . Marshal.unpack++++singletonRange :: n -> Range n+singletonRange n = Range n n++unzipRange :: NiceValue.T (Range n) -> Range (NiceValue.T n)+unzipRange (NiceValue.Cons (Range from to)) =+   Range (NiceValue.Cons from) (NiceValue.Cons to)++zipRange :: NiceValue.T n -> NiceValue.T n -> NiceValue.T (Range n)+zipRange (NiceValue.Cons from) (NiceValue.Cons to) =+   NiceValue.Cons (Range from to)++instance (Tuple.Undefined n) => Tuple.Undefined (Range n) where+   undef = Range Tuple.undef Tuple.undef++instance (Tuple.Value n) => Tuple.Value (Range n) where+   type ValueOf (Range n) = Range (Tuple.ValueOf n)+   valueOf (Range from to) = Range (Tuple.valueOf from) (Tuple.valueOf to)++instance (NiceValue.C n) => NiceValue.C (Range n) where+   type Repr (Range n) = Range (NiceValue.Repr n)+   cons (Range from to) = zipRange (NiceValue.cons from) (NiceValue.cons to)+   undef = NiceValue.compose $ singletonRange NiceValue.undef+   zero = NiceValue.compose $ singletonRange NiceValue.zero+   phi bb a =+      case unzipRange a of+         Range a0 a1 ->+            Monad.lift2 zipRange (NiceValue.phi bb a0) (NiceValue.phi bb a1)+   addPhi bb a b =+      case (unzipRange a, unzipRange b) of+         (Range a0 a1, Range b0 b1) ->+            NiceValue.addPhi bb a0 b0 >>+            NiceValue.addPhi bb a1 b1++type instance+   NiceValue.Decomposed f (Range pn) = Range (NiceValue.Decomposed f pn)+type instance+   NiceValue.PatternTuple (Range pn) = Range (NiceValue.PatternTuple pn)++instance (NiceValue.Compose n) => NiceValue.Compose (Range n) where+   type Composed (Range n) = Range (NiceValue.Composed n)+   compose (Range from to) =+      zipRange (NiceValue.compose from) (NiceValue.compose to)++instance (NiceValue.Decompose pn) => NiceValue.Decompose (Range pn) where+   decompose (Range pfrom pto) rng =+      case unzipRange rng of+         Range from to ->+            Range+               (NiceValue.decompose pfrom from)+               (NiceValue.decompose pto to)++++singletonShifted :: n -> Shifted n+singletonShifted n = Shifted n n++unzipShifted :: NiceValue.T (Shifted n) -> Shifted (NiceValue.T n)+unzipShifted (NiceValue.Cons (Shifted from to)) =+   Shifted (NiceValue.Cons from) (NiceValue.Cons to)++zipShifted :: NiceValue.T n -> NiceValue.T n -> NiceValue.T (Shifted n)+zipShifted (NiceValue.Cons from) (NiceValue.Cons to) =+   NiceValue.Cons (Shifted from to)++instance (Tuple.Undefined n) => Tuple.Undefined (Shifted n) where+   undef = Shifted Tuple.undef Tuple.undef++instance (Tuple.Value n) => Tuple.Value (Shifted n) where+   type ValueOf (Shifted n) = Shifted (Tuple.ValueOf n)+   valueOf (Shifted start len) =+      Shifted (Tuple.valueOf start) (Tuple.valueOf len)++instance (NiceValue.C n) => NiceValue.C (Shifted n) where+   type Repr (Shifted n) = Shifted (NiceValue.Repr n)+   cons (Shifted start len) =+      zipShifted (NiceValue.cons start) (NiceValue.cons len)+   undef = NiceValue.compose $ singletonShifted NiceValue.undef+   zero = NiceValue.compose $ singletonShifted NiceValue.zero+   phi bb a =+      case unzipShifted a of+         Shifted a0 a1 ->+            Monad.lift2 zipShifted+               (NiceValue.phi bb a0) (NiceValue.phi bb a1)+   addPhi bb a b =+      case (unzipShifted a, unzipShifted b) of+         (Shifted a0 a1, Shifted b0 b1) ->+            NiceValue.addPhi bb a0 b0 >>+            NiceValue.addPhi bb a1 b1++type instance+   NiceValue.Decomposed f (Shifted pn) =+      Shifted (NiceValue.Decomposed f pn)+type instance+   NiceValue.PatternTuple (Shifted pn) =+      Shifted (NiceValue.PatternTuple pn)++instance (NiceValue.Compose n) => NiceValue.Compose (Shifted n) where+   type Composed (Shifted n) = Shifted (NiceValue.Composed n)+   compose (Shifted start len) =+      zipShifted (NiceValue.compose start) (NiceValue.compose len)++instance (NiceValue.Decompose pn) => NiceValue.Decompose (Shifted pn) where+   decompose (Shifted pstart plen) rng =+      case unzipShifted rng of+         Shifted start len ->+            Shifted+               (NiceValue.decompose pstart start)+               (NiceValue.decompose plen len)++++unzipCyclic :: NiceValue.T (Cyclic n) -> Cyclic (NiceValue.T n)+unzipCyclic (NiceValue.Cons (Cyclic n)) = Cyclic (NiceValue.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 $ \(NiceValue.Cons n) -> NiceValue.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 (NiceValue.C n) => NiceValue.C (Cyclic n) where+   type Repr (Cyclic n) = Cyclic (NiceValue.Repr n)+   cons (Cyclic n) = cyclic (NiceValue.cons n)+   undef = cyclic NiceValue.undef+   zero = cyclic NiceValue.zero+   phi bb = Monad.lift cyclic . NiceValue.phi bb . cyclicSize+   addPhi bb a b = NiceValue.addPhi bb (cyclicSize a) (cyclicSize b)++type instance+   NiceValue.Decomposed f (Cyclic pn) = Cyclic (NiceValue.Decomposed f pn)+type instance+   NiceValue.PatternTuple (Cyclic pn) = Cyclic (NiceValue.PatternTuple pn)++instance (NiceValue.Compose n) => NiceValue.Compose (Cyclic n) where+   type Composed (Cyclic n) = Cyclic (NiceValue.Composed n)+   compose (Cyclic n) = cyclic (NiceValue.compose n)++instance (NiceValue.Decompose pn) => NiceValue.Decompose (Cyclic pn) where+   decompose (Cyclic p) sh = NiceValue.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) => NiceValue.C (Enumeration enum) where+   type Repr (Enumeration enum) = ()+   cons = NiceValue.consUnit+   undef = NiceValue.undefUnit+   zero = NiceValue.zeroUnit+   phi = NiceValue.phiUnit+   addPhi = NiceValue.addPhiUnit++type instance NiceValue.Decomposed f (Enumeration enum) = Enumeration enum+type instance NiceValue.PatternTuple (Enumeration enum) = Enumeration enum++instance+      (Enum enum, Bounded enum) => NiceValue.Compose (Enumeration enum) where+   type Composed (Enumeration enum) = Enumeration enum+   compose = NiceValue.cons++instance NiceValue.Decompose (Enumeration enum) where+   decompose Enumeration _ = Enumeration+++instance (Enum enum, Bounded enum) => Expr.Compose (Enumeration enum) where+   type Composed (Enumeration enum) = Enumeration enum+   compose = Expr.cons++instance Expr.Decompose (Enumeration enum) where+   decompose Enumeration _ = Enumeration
− src/Data/Array/Knead/Simple/Fold.hs 
@@ -1,94 +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,-   Linear,-   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.Index.Linear as Linear-import qualified Data.Array.Knead.Index.Linear.Int as IndexInt-import qualified Data.Array.Knead.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, unExp, )-import Data.Array.Knead.Index.Linear ((#:.), (:.)((:.)), )--import qualified LLVM.Extra.Multi.Value as MultiValue-import LLVM.Extra.Multi.Value (atom, )--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 Linear sh0 sh1 = T (Linear.Shape sh0) (Linear.Shape sh1)--passAny :: Linear sh sh a-passAny = Cons id (const id)--pass ::-   Linear sh0 sh1 a ->-   Linear (sh0:.i) (sh1:.i) a-pass (Cons fsh reduce) =-   Cons-      (Expr.modify (Linear.shape (atom:.atom)) $ \(sh:.s) -> fsh sh :. s)-      (\sh code ->-       Linear.switchR $ \jx j ->-          reduce (Linear.tail sh) (\kx -> code (kx #:. j)) jx)---fold1CodeLinear ::-   (MultiValue.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Exp IndexInt.Int ->-   (Val (Linear.Index (sh :. IndexInt.Int)) -> Code r a) ->-   (Val (Linear.Index sh) -> Code r a)-fold1CodeLinear f nc code ix =-   Core.fold1Code f (IndexInt.decons nc)-      (\jx j -> code (jx #:. IndexInt.cons j))-      ix--fold ::-   (MultiValue.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Linear sh0 sh1 a ->-   Linear (sh0:.IndexInt.Int) sh1 a-fold f (Cons fsh reduce) =-   Cons-      (fsh . Linear.tail)-      (\sh code jx ->-          reduce (Linear.tail sh)-             (fold1CodeLinear f (Expr.lift0 (Linear.head sh)) code) jx)---instance Core.Process (T sh0 sh1 a) where
− src/Data/Array/Knead/Simple/Physical.hs 
@@ -1,223 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module Data.Array.Knead.Simple.Physical (-   Array(Array, shape, buffer), -- data constructor intended for PhysicalParameterized-   toList,-   fromList,-   vectorFromList,-   with,-   render,-   scanl1,-   mapAccumL,-   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.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import qualified Data.Array.Knead.Code as Code-import Data.Array.Knead.Expression (Exp, unExp, )-import Data.Array.Knead.Code (getElementPtr, compile, )--import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Memory as Memory-import qualified LLVM.Extra.Maybe as Maybe--import qualified LLVM.Core as LLVM--import Foreign.Marshal.Array (pokeArray, peekArray, )-import Foreign.Marshal.Alloc (alloca, )-import Foreign.Storable (Storable, peek, )-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray, )-import Foreign.Ptr (FunPtr, Ptr, )--import Control.Monad.HT (void, )-import Control.Applicative (liftA2, (<$>), )-import Data.Word (Word32, )--import Prelude hiding (scanl1, )---data Array sh a =-   Array {-      shape :: sh,-      buffer :: ForeignPtr a-   }---toList ::-   (Shape.C sh, Storable a) =>-   Array sh a -> IO [a]-toList (Array sh fptr) =-   withForeignPtr fptr $ peekArray (Shape.size sh)--fromList ::-   (Shape.C sh, Storable a) =>-   sh -> [a] -> IO (Array sh a)-fromList sh xs = do-   let size = Shape.size sh-   fptr <- mallocForeignPtrArray size-   withForeignPtr fptr $-      \ptr ->-         pokeArray ptr $-         take size $-         xs ++ repeat (error "Array.Knead.Physical.fromList: list too short for shape")-   return (Array sh fptr)--vectorFromList ::-   (Shape.C sh, Num sh, Storable a) =>-   [a] -> IO (Array sh a)-vectorFromList xs = do-   let size = length xs-   fptr <- mallocForeignPtrArray size-   withForeignPtr fptr $ flip pokeArray xs-   return (Array (fromIntegral size) fptr)---{- |-The symbolic array is only valid inside the enclosed action.--}-with ::-   (Shape.C sh, MultiValueMemory.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 ->-            Memory.load =<<-               getElementPtr (Shape.value sh)-                  (LLVM.valueOf (MultiValueMemory.castStructPtr ptr)) ix)---type Importer f = FunPtr f -> f--foreign import ccall safe "dynamic" callShaper ::-   Importer (Ptr sh -> IO Word32)--foreign import ccall safe "dynamic" callRenderer ::-   Importer (Ptr sh -> Ptr am -> IO ())---materialize ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a, MultiValueMemory.Struct a ~ am) =>-   String ->-   Exp sh ->-   (LLVM.Value (Ptr (MultiValueMemory.Struct sh)) ->-    LLVM.Value (Ptr am) -> LLVM.CodeGenFunction () ()) ->-   IO (Array sh a)-materialize name esh code =-   alloca $ \shptr -> do-      (fsh, farr) <--         compile name $-         liftA2 (,)-            (Code.createFunction callShaper "shape" $ \ptr -> do-               sh <- unExp esh-               MultiValueMemory.store sh ptr-               Shape.sizeCode sh >>= LLVM.ret)-            (Code.createFunction callRenderer "fill"-               (\paramPtr arrayPtr -> code paramPtr arrayPtr >> LLVM.ret ()))-      let lshptr = MultiValueMemory.castStructPtr shptr-      n <- fsh lshptr-      fptr <- mallocForeignPtrArray (fromIntegral n)-      withForeignPtr fptr $ farr lshptr . MultiValueMemory.castStructPtr-      sh <- peek shptr-      return (Array sh fptr)--render ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.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 = do-             flip Memory.store p =<< code ix-             A.advanceArrayElementPtr p-      sh <- Shape.load esh sptr-      void $ Shape.loop step sh ptr--scanl1 ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array (sh, Word32) a -> IO (Array (sh, Word32) a)-scanl1 = scanl1Gen--scanl1Gen ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    Storable a, MultiValueMemory.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array (sh, n) a -> IO (Array (sh, n) a)-scanl1Gen 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)-                Memory.store acc1 ptr0-                ptr1 <- A.advanceArrayElementPtr ptr0-                return (ptr1, Maybe.just acc1)-      void $ Shape.loop step sh ptr--mapAccumL ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    MultiValue.C acc,-    Storable x, MultiValueMemory.C x,-    Storable y, MultiValueMemory.C y) =>-   (Exp acc -> Exp x -> Exp (acc,y)) ->-   Sym.Array sh acc -> Sym.Array (sh, n) x -> IO (Array (sh, n) y)-mapAccumL f arrInit arrData =-   materialize "mapAccumL" (Sym.shape arrData) $-      Priv.mapAccumL f arrInit arrData--scatterMaybe ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Storable sh1, MultiValueMemory.C sh1,-    Storable a, MultiValueMemory.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,-    Storable sh1, MultiValueMemory.C sh1,-    Storable a, MultiValueMemory.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,-    Storable sh1, MultiValueMemory.C sh1,-    Storable a, MultiValueMemory.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,134 +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.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, unExp)-import Data.Array.Knead.Code (getElementPtr)--import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Memory as Memory--import qualified LLVM.Core as LLVM--import Foreign.Storable (Storable, )-import Foreign.Ptr (Ptr, )--import Control.Monad.HT (void, )-import Control.Applicative ((<$>), )--import Data.Tuple.HT (mapSnd, )----mapAccumL ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    MultiValue.C acc,-    Storable x, MultiValueMemory.C x,-    Storable y, MultiValueMemory.C y) =>-   (Exp acc -> Exp x -> Exp (acc,y)) ->-   Sym.Array sh acc -> Sym.Array (sh, n) x ->-   LLVM.Value (Ptr (MultiValueMemory.Struct (sh,n))) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct y)) ->-   LLVM.CodeGenFunction r ()-mapAccumL 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-         fmap fst $-          (\body -> Shape.loop body n (ptrStart, accInit)) $-                \k0 (ptr0, acc0) -> do-             x <- code $ MultiValue.zip ix k0-             (acc1,y) <- MultiValue.unzip <$> Expr.unliftM2 f acc0 x-             Memory.store y ptr0-             ptr1 <- A.advanceArrayElementPtr ptr0-             return (ptr1, acc1)-   void $ Shape.loop step sh ptr--foldOuterL ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    MultiValueMemory.C a) =>-   (Exp a -> Exp b -> Exp a) ->-   Sym.Array sh a -> Sym.Array (n,sh) b ->-   LLVM.Value (Ptr (MultiValueMemory.Struct sh)) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->-   LLVM.CodeGenFunction r ()-foldOuterL f (Sym.Array _ initCode) (Sym.Array esh code) _sptr ptr = do-   -- (n,sh) <- MultiValue.unzip <$> Shape.load esh sptr-   (n,sh) <- MultiValue.unzip <$> unExp esh-   let fillInit ix ptr0 = do-         a <- initCode ix-         Memory.store a ptr0-         A.advanceArrayElementPtr ptr0-   void $ Shape.loop fillInit sh ptr--   let step k ix ptr0 = do-       b <- code $ MultiValue.zip k ix-       a0 <- Memory.load ptr0-       a1 <- Expr.unliftM2 f a0 b-       Memory.store a1 ptr0-       A.advanceArrayElementPtr ptr0-   void $ Shape.loop (\k () -> void $ Shape.loop (step k) sh ptr) n ()--scatterMaybe ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Storable sh1, MultiValueMemory.C sh1,-    Storable a, MultiValueMemory.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array sh1 a -> Sym.Array sh0 (Maybe (ix1, a)) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct sh1)) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->-   LLVM.CodeGenFunction r ()-scatterMaybe accum (Sym.Array esh codeInit) (Sym.Array eish codeMap)-      sptr ptr = do--   let clear ix p = do-         flip Memory.store p =<< codeInit ix-         A.advanceArrayElementPtr p-   sh <- Shape.load esh sptr-   void $ Shape.loop clear sh 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 Memory.store p-               =<< Expr.unliftM2 (flip accum) a-               =<< Memory.load p-   Shape.loop fill ish ()--scatter ::-   (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Storable sh1, MultiValueMemory.C sh1,-    Storable a, MultiValueMemory.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Sym.Array sh1 a ->-   Sym.Array sh0 (Shape.Index sh1, a) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct sh1)) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->-   LLVM.CodeGenFunction r ()-scatter accum (Sym.Array esh codeInit) (Sym.Array eish codeMap) sptr ptr = do-   let clear ix p = do-         flip Memory.store p =<< codeInit ix-         A.advanceArrayElementPtr p-   sh <- Shape.load esh sptr-   void $ Shape.loop clear sh ptr--   ish <- unExp eish-   let fill ix () = do-         (jx, a) <- fmap MultiValue.unzip $ codeMap ix-         p <- getElementPtr sh ptr jx-         flip Memory.store p-            =<< Expr.unliftM2 (flip accum) a-            =<< Memory.load p-   Shape.loop fill ish ()
− src/Data/Array/Knead/Simple/Private.hs 
@@ -1,214 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-module Data.Array.Knead.Simple.Private where--import qualified Data.Array.Knead.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp(Exp), )--import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Monad as Monad-import qualified LLVM.Extra.Maybe as Maybe-import qualified LLVM.Extra.Control as C-import qualified LLVM.Core as LLVM--import qualified Control.Category as Cat-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.liftR2 (Expr.unliftM2 f)-               (codeA =<< Expr.unliftM1 projectIndex0 ix)-               (codeB =<< Expr.unliftM1 projectIndex1 ix))---id ::-   (Shape.C sh, Shape.Index sh ~ ix) =>-   Exp sh -> Array sh ix-id sh = 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 sh1, Shape.Index sh1 ~ ix1, MultiValue.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Exp sh1 ->-   (Val ix0 -> Val ix1 -> Code r a) ->-   (Val ix0 -> Code r a)-fold1Code f (Exp nc) code ix = do-   n <- nc-   fmap Maybe.fromJust $-      Shape.loop-         (\i0 macc0 -> do-            a <- code ix 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 -> Array () a-fold1All f (Array esh code) =-   fold1 f $-   Array-      (Expr.lift1 (MultiValue.zip (MultiValue.Cons ())) esh)-      (code . MultiValue.snd)---{--'Shape.loop' does not support an early exit.-I wished the LLVM optimizer would rewrite the loop accordingly.-Unfortunately, it does not.--}-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 <--      Shape.loop-         (\i found ->-            C.ifThenElse (Maybe.isJust found)-               (return found)-               (do-                  a <- code i-                  MultiValue.Cons b <- Expr.unliftM1 p a-                  return $ Maybe.fromBool b a))-         n Maybe.nothing-   Maybe.run finalFound-      (return MultiValue.nothing)-      (return . MultiValue.just)--{- |-In principle this can be implemented using fold1All-but this one should have short-cut semantics.-Currently it has not! :-(-@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,75 +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.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, )--import qualified LLVM.Extra.Monad 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.liftR2 (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,192 +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,-   Linear,-   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.Index.Linear as Linear-import qualified Data.Array.Knead.Index.Nested.Shape as Shape-import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Index.Linear ((#:.), (:.)((:.)), )-import Data.Array.Knead.Expression (Exp, )--import qualified LLVM.Extra.Multi.Value as MultiValue-import LLVM.Extra.Multi.Value (atom, )--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 Linear sh0 sh1 = T (Linear.Shape sh0) (Linear.Shape sh1)--{- |-Like @Any@ in @accelerate@.--}-passAny :: Linear sh sh-passAny = Cons P.id P.id--{- |-Like @All@ in @accelerate@.--}-pass ::-   Linear sh0 sh1 ->-   Linear (sh0:.i) (sh1:.i)-pass (Cons fsh fix) =-   Cons-      (Expr.modify (Linear.shape (atom:.atom)) $ \(sh:.s) -> fsh sh :. s)-      (Expr.modify (Linear.index (atom:.atom)) $ \(ix:.i) -> fix ix :. i)--{- |-Like @Int@ in @accelerate/slice@.--}-pick ::-   Exp i ->-   Linear sh0 sh1 ->-   Linear (sh0:.i) sh1-pick i (Cons fsh fix) =-   Cons-      (fsh . Linear.tail)-      (\ix -> fix ix #:. i)--{- |-Like @Int@ in @accelerate/replicate@.--}-extrude ::-   Exp i ->-   Linear sh0 sh1 ->-   Linear sh0 (sh1:.i)-extrude n (Cons fsh fix) =-   Cons-      (\sh -> fsh sh #:. n)-      (fix . Linear.tail)---instance Core.Process (T sh0 sh1) where
− src/Data/Array/Knead/Simple/Symbolic.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE GADTs #-}-module Data.Array.Knead.Simple.Symbolic (-   Core.Array,-   Core.C(..),-   Exp,-   shape,-   (Core.!),-   Core.the,-   Core.fromScalar,-   Core.fill,-   gather,-   backpermute,-   Core.backpermute2,-   Core.id,-   Core.map,-   Core.mapWithIndex,-   zipWith,-   zipWith3,-   zipWith4,-   zip,-   zip3,-   zip4,-   fold1,-   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, fold1, gather, )--import qualified Data.Array.Knead.Index.Nested.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 Prelude hiding (zipWith, zipWith3, zip, zip3, replicate, )---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)---fold1All ::-   (Core.C array, Shape.C sh, Shape.Scalar z, MultiValue.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   array sh a -> array z a-fold1All f =-   Core.lift1 $ \arr ->-      fold1 f $-      backpermute-         (Expr.lift2 MultiValue.zip Shape.scalar (shape arr))-         (Expr.lift1 MultiValue.snd)-         arr
+ 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.Nice.Value as NiceValue++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,+    NiceValue.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 NiceValue.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 NiceValue.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 NiceValue.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.Nice.Value as NiceValue+import LLVM.Extra.Nice.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, NiceValue.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, NiceValue.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, NiceValue.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 (NiceValue.compose . Shape.ZeroBased) $ Index.decons nc)+      (\j -> code (ix #:. Index.cons j))++fold ::+   (Unary.Natural rank0, Unary.Natural rank1, NiceValue.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.Nice.Value.Storable as Storable+import qualified LLVM.Extra.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value as NiceValue+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, NiceValue.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) <- NiceValue.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 $ NiceValue.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,+    NiceValue.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 NiceValue.zip . ixmap) input)
+ src/Data/Array/Knead/Symbolic/PhysicalParametric.hs view
@@ -0,0 +1,455 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Data.Array.Knead.Symbolic.PhysicalParametric (+   the,+   theMarshal,+   render,+   MapFilter(..),+   mapFilter,+   FilterOuter(..),+   filterOuter,+   Scatter(..),+   scatter,+   ScatterMaybe(..),+   scatterMaybe,+   MapAccumLSimple(..),+   mapAccumLSimple,+   MapAccumLSequence(..),+   mapAccumLSequence,+   MapAccumL(..),+   mapAccumL,+   FoldOuterL(..),+   foldOuterL,+   AddDimension(..),+   addDimension,++   Parametric,+   Rendered,+   ) where++import qualified Data.Array.Knead.Symbolic.PhysicalPrivate as Priv+import qualified Data.Array.Knead.Symbolic.Private as Core+import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Symbolic.PhysicalPrivate (MarshalPtr)++import Data.Array.Comfort.Storable.Unchecked (Array(Array))++import qualified LLVM.DSL.Execution as Code+import LLVM.DSL.Expression (Exp(Exp), unExp)++import qualified LLVM.Extra.Nice.Value.Storable as Storable+import qualified LLVM.Extra.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value as NiceValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM++import Foreign.Marshal.Array (allocaArray, )+import Foreign.Marshal.Alloc (alloca, )+import Foreign.Storable (Storable, peek, peekElemOff, )+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray, )+import Foreign.Ptr (FunPtr, Ptr, )++import Control.Exception (finally)+import Control.Monad.HT (void, )+import Control.Applicative (liftA2, )+++mallocArray :: (Storable a) => Shape.Size -> IO (ForeignPtr a)+mallocArray = mallocForeignPtrArray . fromIntegral+++type Importer f = FunPtr f -> f+++++type Parametric p a = Exp p -> a+type Rendered p a = IO (p, IO ()) -> IO a++withManagedParam :: Monad m => (p -> IO a) -> m (Rendered p a)+withManagedParam act =+   return $ \create -> do+      (param, final) <- create+      finally (act param) final++++foreign import ccall safe "dynamic" callThe ::+   Importer (LLVM.Ptr param -> Ptr a -> IO ())++the ::+   (Marshal.C p, Shape.Scalar z, Storable.C a) =>+   Parametric p (Core.Array z a) -> IO (Rendered p a)+the arr = do+   func <-+      Code.compile "the" $+      Code.createFunction callThe "eval" $+      \paramPtr resultPtr -> do+         case arr $ Exp (Memory.load paramPtr) of+            Core.Array z code ->+               code (Shape.zeroIndex z) >>=+               flip Storable.store resultPtr+   withManagedParam $ \param ->+      Marshal.with param $ \pptr ->+      alloca $ \aptr -> func pptr aptr >> peek aptr++foreign import ccall safe "dynamic" callTheMarshal ::+   Importer (LLVM.Ptr param -> LLVM.Ptr a -> IO ())++theMarshal ::+   (Marshal.C p, Shape.Scalar z, Marshal.C a) =>+   Parametric p (Core.Array z a) -> IO (Rendered p a)+theMarshal arr = do+   func <-+      Code.compile "the-marshal" $+      Code.createFunction callTheMarshal "eval" $+      \paramPtr resultPtr -> do+         case arr $ Exp (Memory.load paramPtr) of+            Core.Array z code ->+               code (Shape.zeroIndex z) >>=+               flip Memory.store resultPtr+   withManagedParam $ \param ->+      Marshal.with param $ \pptr ->+      Marshal.alloca $ \aptr ->+         func pptr aptr >>+         Marshal.peek aptr+++++foreign import ccall safe "dynamic" callShaper ::+   Importer (LLVM.Ptr param -> LLVM.Ptr shape -> IO Shape.Size)++foreign import ccall safe "dynamic" callFill ::+   Importer (LLVM.Ptr param -> LLVM.Ptr shape -> Ptr a -> IO ())+++{-+Attention:+The 'fill' function may alter the shape.+An example is 'mapFilter'.+-}+materialize ::+   (Shape.C sh, Marshal.C sh, Marshal.C p, Storable.C a) =>+   String ->+   (core -> Exp sh) ->+   (core ->+    LLVM.Value (MarshalPtr sh) -> LLVM.Value (Ptr a) ->+    LLVM.CodeGenFunction () ()) ->+   Parametric p core -> IO (Rendered p (Array sh a))+materialize name shape fill core = do+   (fsh, farr) <-+      Code.compile name $+      liftA2 (,)+         (Code.createFunction callShaper "shape" $+          \paramPtr resultPtr -> do+            sh <- unExp $ shape $ core $ Exp (Memory.load paramPtr)+            Memory.store sh resultPtr+            Shape.size sh)+         (Code.createFunction callFill "fill" $+          \paramPtr shapePtr bufferPtr ->+            fill (core $ Exp (Memory.load paramPtr)) shapePtr bufferPtr)++   withManagedParam $ \param ->+      Marshal.alloca $ \shptr ->+      Marshal.with param $ \paramPtr -> do+         fptr <- mallocArray =<< fsh paramPtr shptr+         withForeignPtr fptr $ farr paramPtr shptr+         sh <- Marshal.peek shptr+         return (Array sh fptr)+++foreign import ccall safe "dynamic" callFillExpArray ::+   Importer (LLVM.Ptr param -> Ptr final -> LLVM.Ptr shape -> Ptr a -> IO ())+++materializeExpArray ::+   (Shape.C sh, Marshal.C sh, Marshal.C p, Storable.C a, Storable.C b) =>+   String ->+   (core -> Exp sh) ->+   (core ->+    LLVM.Value (Ptr b) ->+    LLVM.Value (MarshalPtr sh) ->+    LLVM.Value (Ptr a) ->+    LLVM.CodeGenFunction () ()) ->+   Parametric p core -> IO (Rendered p (b, Array sh a))+materializeExpArray name shape fill core = do+   (fsh, farr) <-+      Code.compile name $+      liftA2 (,)+         (Code.createFunction callShaper "shape" $+          \paramPtr resultPtr -> do+            sh <- unExp $ shape $ core $ Exp (Memory.load paramPtr)+            Memory.store sh resultPtr+            Shape.size sh)+         (Code.createFunction callFillExpArray "fill" $+          \paramPtr finalPtr shapePtr bufferPtr ->+            fill+               (core $ Exp (Memory.load paramPtr))+               finalPtr shapePtr bufferPtr)++   withManagedParam $ \param ->+      Marshal.alloca $ \shptr ->+      alloca $ \finalPtr ->+      Marshal.with param $ \paramPtr -> do+         fptr <- mallocArray =<< fsh paramPtr shptr+         withForeignPtr fptr $ farr paramPtr finalPtr shptr+         sh <- Marshal.peek shptr+         final <- peek finalPtr+         return (final, Array sh fptr)+++foreign import ccall safe "dynamic" callShaper2 ::+   Importer+      (LLVM.Ptr param ->+       LLVM.Ptr shapeA -> LLVM.Ptr shapeB -> Ptr Shape.Size -> IO ())++foreign import ccall safe "dynamic" callFill2 ::+   Importer+      (LLVM.Ptr param ->+       LLVM.Ptr shapeA -> Ptr a -> LLVM.Ptr shapeB -> Ptr b -> IO ())+++materialize2 ::+   (Shape.C sha, Marshal.C sha,+    Shape.C shb, Marshal.C shb,+    Marshal.C p, Storable.C a, Storable.C b) =>+   String ->+   (core -> Exp (sha,shb)) ->+   (core ->+    (LLVM.Value (MarshalPtr sha), LLVM.Value (Ptr a)) ->+    (LLVM.Value (MarshalPtr shb), LLVM.Value (Ptr b)) ->+    LLVM.CodeGenFunction () ()) ->+   Parametric p core -> IO (Rendered p (Array sha a, Array shb b))+materialize2 name shape fill core = do+   (fsh, farr) <-+      Code.compile name $+      liftA2 (,)+         (Code.createFunction callShaper2 "shape" $+          \paramPtr shapeAPtr shapeBPtr sizesPtr -> do+            (sha,shb) <-+               fmap NiceValue.unzip $ unExp $+               shape $ core $ Exp (Memory.load paramPtr)+            Memory.store sha shapeAPtr+            Memory.store shb shapeBPtr+            sizeAPtr <- LLVM.bitcast sizesPtr+            flip LLVM.store sizeAPtr =<< Shape.size sha+            sizeBPtr <- A.advanceArrayElementPtr sizeAPtr+            flip LLVM.store sizeBPtr =<< Shape.size shb)+         (Code.createFunction callFill2 "fill" $+          \paramPtr shapeAPtr bufferAPtr shapeBPtr bufferBPtr ->+            fill+               (core $ Exp (Memory.load paramPtr))+               (shapeAPtr, bufferAPtr) (shapeBPtr, bufferBPtr))++   withManagedParam $ \param ->+      Marshal.alloca $ \shaPtr ->+      Marshal.alloca $ \shbPtr ->+      allocaArray 2 $ \sizesPtr ->+      Marshal.with param $ \paramPtr -> do+         fsh paramPtr shaPtr shbPtr sizesPtr+         afptr <- mallocArray =<< peekElemOff sizesPtr 0+         bfptr <- mallocArray =<< peekElemOff sizesPtr 1+         withForeignPtr afptr $ \aptr ->+            withForeignPtr bfptr $ \bptr ->+            farr paramPtr shaPtr aptr shbPtr bptr+         sha <- Marshal.peek shaPtr+         shb <- Marshal.peek shbPtr+         return (Array sha afptr, Array shb bfptr)+++render ::+   (Shape.C sh, Shape.Index sh ~ ix, Marshal.C sh,+    Marshal.C p, Storable.C a) =>+   Parametric p (Core.Array sh a) -> IO (Rendered p (Array sh a))+render =+   materialize "render" Core.shape+      (\(Core.Array esh code) shapePtr bufferPtr -> do+         let step ix p = flip Storable.storeNext p =<< code ix+         sh <- Shape.load esh shapePtr+         void $ Shape.loop step sh bufferPtr)+++data Scatter sh0 sh1 a =+   Scatter {+      scatterAccum :: Exp a -> Exp a -> Exp a,+      scatterInit :: Core.Array sh1 a,+      scatterMap :: Core.Array sh0 (Shape.Index sh1, a)+   }++scatter ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,+    Marshal.C p, Storable.C a) =>+   Parametric p (Scatter sh0 sh1 a) -> IO (Rendered p (Array sh1 a))+scatter =+   materialize "scatter"+      (Core.shape . scatterInit)+      (\(Scatter accum arrInit arrMap) ->+         Priv.scatter accum arrInit arrMap)++++data ScatterMaybe sh0 sh1 a =+   ScatterMaybe {+      scatterMaybeAccum :: Exp a -> Exp a -> Exp a,+      scatterMaybeInit :: Core.Array sh1 a,+      scatterMaybeMap :: Core.Array sh0 (Maybe (Shape.Index sh1, a))+   }++scatterMaybe ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1,+    Marshal.C p, Storable.C a) =>+   Parametric p (ScatterMaybe sh0 sh1 a) -> IO (Rendered p (Array sh1 a))+scatterMaybe =+   materialize "scatterMaybe"+      (Core.shape . scatterMaybeInit)+      (\(ScatterMaybe accum arrInit arrMap) ->+         Priv.scatterMaybe accum arrInit arrMap)+++data MapAccumLSimple sh n acc a b =+   MapAccumLSimple {+      mapAccumLSimpleAccum :: Exp acc -> Exp a -> Exp (acc,b),+      mapAccumLSimpleInit :: Core.Array sh acc,+      mapAccumLSimpleArray :: Core.Array (sh, n) a+   }++mapAccumLSimple ::+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    NiceValue.C acc, Marshal.C p, Storable.C a, Storable.C b) =>+   Parametric p (MapAccumLSimple sh n acc a b) ->+   IO (Rendered p (Array (sh,n) b))+mapAccumLSimple =+   materialize "mapAccumLSimple"+      (Core.shape . mapAccumLSimpleArray)+      (\(MapAccumLSimple f arrInit arrData) ->+         Priv.mapAccumLSimple f arrInit arrData)+++data MapAccumLSequence n acc final a b =+   MapAccumLSequence {+      mapAccumLSequenceAccum :: Exp acc -> Exp a -> Exp (acc,b),+      mapAccumLSequenceFinal :: Exp acc -> Exp final,+      mapAccumLSequenceInit :: Exp acc,+      mapAccumLSequenceArray :: Core.Array n a+   }++-- FIXME: check correct size of array of initial values+mapAccumLSequence ::+   (Shape.C n, Marshal.C n, NiceValue.C acc, Storable.C final,+    Marshal.C p, Storable.C a, Storable.C b) =>+   Parametric p (MapAccumLSequence n acc final a b) ->+   IO (Rendered p (final, Array n b))+mapAccumLSequence =+   materializeExpArray "mapAccumLSequence"+      (Core.shape . mapAccumLSequenceArray)+      (\(MapAccumLSequence f final expInit arr) ->+         Priv.mapAccumLSequence f final expInit arr)+++data MapAccumL sh n acc final a b =+   MapAccumL {+      mapAccumLAccum :: Exp acc -> Exp a -> Exp (acc,b),+      mapAccumLFinal :: Exp acc -> Exp final,+      mapAccumLInit :: Core.Array sh acc,+      mapAccumLArray :: Core.Array (sh, n) a+   }++-- FIXME: check correct size of array of initial values+mapAccumL ::+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    NiceValue.C acc, Storable.C final,+    Marshal.C p, Storable.C a, Storable.C b) =>+   Parametric p (MapAccumL sh n acc final a b) ->+   IO (Rendered p (Array sh final, Array (sh,n) b))+mapAccumL =+   materialize2 "mapAccumL"+      (\core ->+         Expr.zip+            (Core.shape $ mapAccumLInit core)+            (Core.shape $ mapAccumLArray core))+      (\(MapAccumL f final arrInit arrData) ->+         Priv.mapAccumL f final arrInit arrData)+++data FoldOuterL n sh a b =+   FoldOuterL {+      foldOuterLAccum :: Exp a -> Exp b -> Exp a,+      foldOuterLInit :: Core.Array sh a,+      foldOuterLArray :: Core.Array (n,sh) b+   }++-- FIXME: check correct size of array of initial values+foldOuterL ::+   (Shape.C n, Marshal.C n,+    Shape.C sh, Marshal.C sh,+    Marshal.C p, Storable.C a) =>+   Parametric p (FoldOuterL n sh a b) -> IO (Rendered p (Array sh a))+foldOuterL =+   materialize "foldOuterL"+      (Core.shape . foldOuterLInit)+      (\(FoldOuterL f arrInit arrData) -> Priv.foldOuterL f arrInit arrData)+++data MapFilter n a b =+   MapFilter {+      mapFilterMap :: Exp a -> Exp b,+      mapFilterPredicate :: Exp a -> Exp Bool,+      mapFilterArray :: Core.Array n a+   }++mapFilter ::+   (Shape.Sequence n, Marshal.C n, Marshal.C p, Storable.C b) =>+   Parametric p (MapFilter n a b) -> IO (Rendered p (Array n b))+mapFilter =+   materialize "mapFilter"+      (Core.shape . mapFilterArray)+      (\(MapFilter f p arr) shapePtr bufferPtr ->+         flip Memory.store shapePtr+            =<< Priv.mapFilter f p arr shapePtr bufferPtr)+++data FilterOuter n sh a =+   FilterOuter {+      filterOuterPredicate :: Core.Array n Bool,+      filterOuterArray :: Core.Array (n,sh) a+   }++-- FIXME: check correct size of row selection array+filterOuter ::+   (Shape.Sequence n, Marshal.C n,+    Shape.C sh, Marshal.C sh,+    Marshal.C p, Storable.C a) =>+   Parametric p (FilterOuter n sh a) -> IO (Rendered p (Array (n,sh) a))+filterOuter =+   materialize "filterOuter"+      (Core.shape . filterOuterArray)+      (\(FilterOuter p arr) shapePtr bufferPtr ->+         flip Memory.store shapePtr+            =<< Priv.filterOuter p arr shapePtr bufferPtr)+++data AddDimension sh n a b =+   AddDimension {+      addDimensionSize :: Exp n,+      addDimensionSelect :: Exp (Shape.Index n) -> Exp a -> Exp b,+      addDimensionArray :: Core.Array sh a+   }++addDimension ::+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    Marshal.C p, Storable.C b) =>+   Parametric p (AddDimension sh n a b) -> IO (Rendered p (Array (sh,n) b))+addDimension =+   materialize "addDimension"+      (\r -> Expr.zip (Core.shape (addDimensionArray r)) (addDimensionSize r))+      (\(AddDimension n select arr) -> Priv.addDimension n select arr)
+ src/Data/Array/Knead/Symbolic/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.Nice.Value.Storable as Storable+import qualified LLVM.Extra.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value as NiceValue+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) =>+   NiceValue.T sh ->+   (NiceValue.T ix -> LLVM.CodeGenFunction r (NiceValue.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 ::+   (NiceValue.C acc, Storable.C b,+    Shape.C sh, Shape.Index sh ~ ix) =>+   (NiceValue.T ix -> LLVM.CodeGenFunction r (NiceValue.T a)) ->+   (Exp acc -> Exp a -> Exp (acc, b)) ->+   NiceValue.T sh ->+   LLVM.Value (Ptr b) -> NiceValue.T acc ->+   LLVM.CodeGenFunction r (LLVM.Value (Ptr b), NiceValue.T acc)+mapAccumLLoop code f n yPtr accInit = do+   let step k0 (ptr0, acc0) = do+         x <- code k0+         (acc1,y) <- NiceValue.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,+    NiceValue.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) <- NiceValue.unzip <$> Shape.load esh sptr+   let step ix ptrStart = do+         accInit <- initCode ix+         fst <$> mapAccumLLoop (code . NiceValue.zip ix) f n ptrStart accInit+   void $ Shape.loop step sh ptr++mapAccumLSequence ::+   (Shape.C n, Marshal.C n,+    NiceValue.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,+    NiceValue.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) <- NiceValue.unzip <$> Shape.load esh sptr+   let step ix (accPtr0, yPtrStart) = do+         accInit <- initCode ix+         (ptrStop, accExit) <-+            mapAccumLLoop (code . NiceValue.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 <- NiceValue.fst <$> unExp esh+   void $ writeArray sh initCode ptr++   let step k ix ptr0 = do+         b <- code $ NiceValue.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 (NiceValue.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+         NiceValue.Cons c <- Expr.unliftM1 p a+         C.ifThen c (dstPtr,dstIx)+            (App.lift2 (,)+               (flip Storable.storeNext dstPtr =<< Expr.unliftM1 f a)+               (NiceValue.inc dstIx))+   Shape.sequenceShapeFromIndex . snd+      =<< Shape.loop step n (ptr, NiceValue.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 (NiceValue.T (n,sh))+filterOuter (Sym.Array _eish selectCode) (Sym.Array esh code) sptr ptr = do+   (n,sh) <- NiceValue.unzip <$> Shape.load esh sptr+   let step k (dstPtr0,dstK) = do+         NiceValue.Cons c <- selectCode k+         C.ifThen c (dstPtr0,dstK)+            (do+               dstPtr1 <- writeArray sh (code . NiceValue.zip k) dstPtr0+               (,) dstPtr1 <$> NiceValue.inc dstK)+   finalN <-+      Shape.sequenceShapeFromIndex . snd+         =<< Shape.loop step n (ptr, NiceValue.zero)+   return $ NiceValue.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+         (NiceValue.Cons c, (jx, a)) <-+            mapSnd NiceValue.unzip . NiceValue.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) <- NiceValue.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) <- NiceValue.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.Nice.Value as NiceValue+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 = NiceValue.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,+    NiceValue.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, NiceValue.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, NiceValue.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 . NiceValue.curry code+++fold1All ::+   (Shape.C sh, NiceValue.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, NiceValue.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+            NiceValue.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 NiceValue.nothing)+      (return . NiceValue.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, NiceValue.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,177 @@+{-# LANGUAGE TypeFamilies #-}+{- |+Apply operations on symbolic arrays to physical ones.+-}+module Data.Array.Knead.Symbolic.Render (+   run,+   MarshalExp(..),+   MapFilter(..),+   FilterOuter(..),+   Scatter(..),+   ScatterMaybe(..),+   MapAccumLSimple(..),+   MapAccumLSequence(..),+   MapAccumL(..),+   FoldOuterL(..),+   AddDimension(..),+   ) where++import qualified Data.Array.Knead.Symbolic.Render.Basic as Render+import qualified Data.Array.Knead.Symbolic.Render.Argument as Arg+import qualified Data.Array.Knead.Symbolic.PhysicalParametric as PhysP+import qualified Data.Array.Knead.Symbolic.Physical as Phys+import qualified Data.Array.Knead.Symbolic.Private as Core+import qualified Data.Array.Knead.Shape as Shape+import Data.Array.Knead.Symbolic.PhysicalParametric+         (MapFilter, FilterOuter,+          MapAccumLSimple, MapAccumLSequence, MapAccumL, FoldOuterL,+          Scatter, ScatterMaybe, AddDimension)++import qualified LLVM.DSL.Render.Run as Run+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Nice.Value.Storable as Storable+import qualified LLVM.Extra.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value as NiceValue++import Prelude2010+import Prelude ()++++class C f where+   type Plain f+   function :: (Marshal.C p) => Run.T IO p f (Plain f)++instance+   (Marshal.C sh, Shape.C sh, Storable.C a) =>+      C (Core.Array sh a) where+   type Plain (Core.Array sh a) = IO (Phys.Array sh a)+   function = Run.Cons PhysP.render++instance+   (Shape.Sequence n, Marshal.C n,+    Storable.C b, NiceValue.C b) =>+      C (MapFilter n a b) where+   type Plain (MapFilter n a b) = IO (Phys.Array n b)+   function = Run.Cons PhysP.mapFilter++instance+   (Shape.Sequence n, Marshal.C n,+    Shape.C sh, Marshal.C sh,+    Storable.C a, NiceValue.C a) =>+      C (FilterOuter n sh a) where+   type Plain (FilterOuter n sh a) = IO (Phys.Array (n,sh) a)+   function = Run.Cons PhysP.filterOuter++instance+   (Shape.C sh0, Marshal.C sh0,+    Shape.C sh1, Marshal.C sh1,+    Storable.C a, NiceValue.C a) =>+      C (Scatter sh0 sh1 a) where+   type Plain (Scatter sh0 sh1 a) = IO (Phys.Array sh1 a)+   function = Run.Cons PhysP.scatter++instance+   (Shape.C sh0, Marshal.C sh0,+    Shape.C sh1, Marshal.C sh1,+    Storable.C a, NiceValue.C a) =>+      C (ScatterMaybe sh0 sh1 a) where+   type Plain (ScatterMaybe sh0 sh1 a) = IO (Phys.Array sh1 a)+   function = Run.Cons PhysP.scatterMaybe++instance+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    NiceValue.C acc,+    Storable.C a, NiceValue.C a,+    Storable.C b, NiceValue.C b) =>+      C (MapAccumLSimple sh n acc a b) where+   type Plain (MapAccumLSimple sh n acc a b) = IO (Phys.Array (sh,n) b)+   function = Run.Cons PhysP.mapAccumLSimple++instance+   (Shape.C n, Marshal.C n,+    NiceValue.C acc,+    Storable.C final, NiceValue.C final,+    Storable.C a, NiceValue.C a,+    Storable.C b, NiceValue.C b) =>+      C (MapAccumLSequence n acc final a b) where+   type Plain (MapAccumLSequence n acc final a b) = IO (final, Phys.Array n b)+   function = Run.Cons PhysP.mapAccumLSequence++instance+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    NiceValue.C acc,+    Storable.C final, NiceValue.C final,+    Storable.C a, NiceValue.C a,+    Storable.C b, NiceValue.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)+   function = Run.Cons PhysP.mapAccumL++instance+   (Shape.C n, Marshal.C n,+    Shape.C sh, Marshal.C sh,+    Storable.C a, NiceValue.C a,+    Storable.C b, NiceValue.C b) =>+      C (FoldOuterL n sh a b) where+   type Plain (FoldOuterL n sh a b) = IO (Phys.Array sh a)+   function = Run.Cons PhysP.foldOuterL++instance+   (Shape.C sh, Marshal.C sh,+    Shape.C n, Marshal.C n,+    Storable.C b, NiceValue.C b) =>+      C (AddDimension sh n a b) where+   type Plain (AddDimension sh n a b) = IO (Phys.Array (sh,n) b)+   function = Run.Cons PhysP.addDimension+++instance (Storable.C a, NiceValue.C a) => C (Exp a) where+   type Plain (Exp a) = IO a+   function = Render.storable++newtype MarshalExp a = MarshalExp {getMarshalExp :: Exp a}++instance (Marshal.C a) => C (MarshalExp a) where+   type Plain (MarshalExp a) = IO a+   function = Run.premapDSL getMarshalExp Render.marshal++instance (Argument arg, C func) => C (arg -> func) where+   type Plain (arg -> func) = PlainArg arg -> Plain func+   function = argument Render.*-> function+++class Argument a where+   type PlainArg a+   argument :: Arg.T (PlainArg a) a++instance Argument () where+   type PlainArg () = ()+   argument = Arg.unit++instance+   (Shape.C sh, Marshal.C sh, Storable.C a) =>+      Argument (Core.Array sh a) where+   type PlainArg (Core.Array sh a) = Phys.Array sh a+   argument = Arg.array++instance (Marshal.C a) => Argument (Exp a) where+   type PlainArg (Exp a) = a+   argument = Arg.primitive++instance (Argument a, Argument b) => Argument (a,b) where+   type PlainArg (a,b) = (PlainArg a, PlainArg b)+   argument = Arg.pair argument argument++instance (Argument a, Argument b, Argument c) => Argument (a,b,c) where+   type PlainArg (a,b,c) = (PlainArg a, PlainArg b, PlainArg c)+   argument = Arg.triple argument argument argument++++run :: (C f) => f -> IO (Plain f)+run = Render.run function
+ src/Data/Array/Knead/Symbolic/Render/Argument.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+module Data.Array.Knead.Symbolic.Render.Argument (+   Arg.T(Arg.Cons),+   Arg.unit,+   Arg.primitive,+   Arg.pair,+   Arg.triple,+   array,+   ) where++import qualified Data.Array.Knead.Symbolic.Physical as Phys+import qualified Data.Array.Knead.Symbolic.Private as Core+import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Code (getElementPtr)++import qualified Data.Array.Comfort.Storable.Unchecked as Array++import qualified LLVM.DSL.Render.Argument as Arg+import LLVM.DSL.Expression (unExp)++import qualified LLVM.Extra.Nice.Value.Storable as Storable+import qualified LLVM.Extra.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value as NiceValue++import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr)++import Prelude2010+import Prelude ()++++array ::+   (Shape.C sh, Marshal.C sh, Storable.C a) =>+   Arg.T (Phys.Array sh a) (Core.Array sh a)+array =+   Arg.Cons+      (Expr.uncurry $ \esh eptr ->+         Core.Array esh+            (\ix -> do+               sh <- unExp esh+               NiceValue.Cons ptr <- unExp eptr+               Storable.load =<< getElementPtr sh ptr ix))+      (\(Array.Array sh fptr) ->+         withForeignPtr fptr $ \ptr ->+         return ((sh, ptr), touchForeignPtr fptr))
+ src/Data/Array/Knead/Symbolic/Render/Basic.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+{- |+Apply operations on symbolic arrays to physical ones.++This is an approach with no pre-defined direction of type dependencies.+-}+module Data.Array.Knead.Symbolic.Render.Basic (+   run,+   (*->),++   storable,+   marshal,+   array,+   scatter,+   ) where++import qualified Data.Array.Knead.Symbolic.Render.Argument as Arg+import qualified Data.Array.Knead.Symbolic.PhysicalParametric as PhysP+import qualified Data.Array.Knead.Symbolic.Physical as Phys+import qualified Data.Array.Knead.Symbolic.Private as Core+import qualified Data.Array.Knead.Shape as Shape++import qualified Data.Array.Comfort.Storable.Unchecked as Array++import qualified LLVM.DSL.Render.Run as Run+import LLVM.DSL.Render.Run (run, (*->))+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Nice.Value.Storable as Storable+import qualified LLVM.Extra.Nice.Value.Marshal as Marshal++import Prelude2010+import Prelude ()++++_example1raw ::+   (Marshal.C sh, Shape.C sh, Marshal.C z, Marshal.C a, Storable.C b) =>+   Run.T IO z (Exp a -> Core.Array sh b) (a -> IO (Phys.Array sh b))+_example1raw = Arg.primitive *-> array++_example2raw ::+   (Marshal.C sh, Shape.C sh,+    Marshal.C z, Marshal.C a, Marshal.C b, Storable.C c) =>+   Run.T IO z+      (Exp a -> Exp b -> Core.Array sh c)+      (a -> b -> IO (Phys.Array sh c))+_example2raw = Arg.primitive *-> Arg.primitive *-> array+++_example2 ::+   (Marshal.C sh, Shape.C sh,+    Marshal.C a, Marshal.C b, Storable.C c) =>+   (Exp a -> Exp b -> Core.Array sh c) ->+   IO (a -> b -> IO (Phys.Array sh c))+_example2 = run (Arg.primitive *-> Arg.primitive *-> array)++_example2exp ::+   (Marshal.C a, Marshal.C b, Storable.C c) =>+   (Exp a -> Exp b -> Exp c) ->+   IO (a -> b -> IO c)+_example2exp = run (Arg.primitive *-> Arg.primitive *-> storable)++_example2marshal ::+   (Marshal.C a, Marshal.C b, Marshal.C c) =>+   (Exp a -> Exp b -> Exp c) ->+   IO (a -> b -> IO c)+_example2marshal = run (Arg.primitive *-> Arg.primitive *-> marshal)++_example2scatter ::+   (Shape.C sh0, Shape.C sh1, Marshal.C sh1,+    Marshal.C a, Marshal.C b, Storable.C c) =>+   (Exp a -> Exp b -> PhysP.Scatter sh0 sh1 c) ->+   IO (a -> b -> IO (Array.Array sh1 c))+_example2scatter = run (Arg.primitive *-> Arg.primitive *-> scatter)+++++singleton :: Exp a -> Core.Array () a+singleton = Core.fromScalar++storable :: (Marshal.C p, Storable.C a) => Run.T IO p (Exp a) (IO a)+storable = Run.Cons $ PhysP.the . fmap singleton++marshal :: (Marshal.C p, Marshal.C a) => Run.T IO p (Exp a) (IO a)+marshal = Run.Cons $ PhysP.theMarshal . fmap singleton++array ::+   (Shape.C sh, Shape.Index sh ~ ix, Marshal.C sh,+    Marshal.C p, Storable.C a) =>+   Run.T IO p (Core.Array sh a) (IO (Phys.Array sh a))+array = Run.Cons PhysP.render+++scatter ::+   (Shape.C sh0, Shape.C sh1, Marshal.C sh1, Marshal.C p, Storable.C a) =>+   Run.T IO p (PhysP.Scatter sh0 sh1 a) (IO (Array.Array sh1 a))+scatter = Run.Cons PhysP.scatter
+ src/Data/Array/Knead/Symbolic/RenderAlt.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE TypeFamilies #-}+{- |+Apply operations on symbolic arrays to physical ones.++In contrast to the "Data.Array.Knead.Symbolic.Render" module,+here we map from Haskell types to LLVM ones.+This is analogous to "Synthesizer.LLVM.Generator.Render".+-}+module Data.Array.Knead.Symbolic.RenderAlt (+   run,+   MarshalValue(..),+   ) where++import qualified Data.Array.Knead.Symbolic.Render.Basic as Render+import qualified Data.Array.Knead.Symbolic.Render.Argument as Arg+import qualified Data.Array.Knead.Symbolic.PhysicalParametric as PhysP+import qualified Data.Array.Knead.Symbolic.Physical as Phys+import qualified Data.Array.Knead.Symbolic.Private as Core+import qualified Data.Array.Knead.Shape as Shape++import qualified LLVM.DSL.Render.Run as Run+import LLVM.DSL.Expression (Exp)++import qualified LLVM.Extra.Nice.Value.Storable as Storable+import qualified LLVM.Extra.Nice.Value.Marshal as Marshal++import Data.Word (Word, Word32)++import Prelude2010+import Prelude ()++++class C f where+   type DSL f+   function :: (Marshal.C p) => Run.T IO p (DSL f) f++instance (C_IO a) => C (IO a) where+   type DSL (IO a) = DSL_IO a+   function = buildIO+++class C_IO f where+   type DSL_IO f+   buildIO :: (Marshal.C p) => Run.T IO p (DSL_IO f) (IO f)++instance+   (Marshal.C sh, Shape.C sh, Storable.C a) =>+      C_IO (Phys.Array sh a) where+   type DSL_IO (Phys.Array sh a) = Core.Array sh a+   buildIO = Run.Cons PhysP.render+++instance C_IO Float where+   type DSL_IO Float = Exp Float+   buildIO = Render.storable++instance C_IO Word32 where+   type DSL_IO Word32 = Exp Word32+   buildIO = Render.storable++newtype MarshalValue a = MarshalValue {getMarshalValue :: a}++instance (Marshal.C a) => C_IO (MarshalValue a) where+   type DSL_IO (MarshalValue a) = Exp a+   buildIO = Run.postmapPlain (fmap MarshalValue) Render.marshal+++instance (Argument arg, C func) => C (arg -> func) where+   type DSL (arg -> func) = DSLArg arg -> DSL func+   function = argument Render.*-> function++++class Argument a where+   type DSLArg a+   argument :: Arg.T a (DSLArg a)++instance Argument () where+   type DSLArg () = ()+   argument = Arg.unit++instance+   (Shape.C sh, Marshal.C sh, Storable.C a) =>+      Argument (Phys.Array sh a) where+   type DSLArg (Phys.Array sh a) = Core.Array sh a+   argument = Arg.array+++instance Argument Float where+   type DSLArg Float = Exp Float+   argument = Arg.primitive++instance Argument Int where+   type DSLArg Int = Exp Int+   argument = Arg.primitive++instance Argument Word where+   type DSLArg Word = Exp Word+   argument = Arg.primitive++instance Argument Word32 where+   type DSLArg Word32 = Exp Word32+   argument = Arg.primitive++instance (Argument a, Argument b) => Argument (a,b) where+   type DSLArg (a,b) = (DSLArg a, DSLArg b)+   argument = Arg.pair argument argument++instance (Argument a, Argument b, Argument c) => Argument (a,b,c) where+   type DSLArg (a,b,c) = (DSLArg a, DSLArg b, DSLArg c)+   argument = Arg.triple argument argument argument++++run :: (C f) => DSL f -> IO f+run = Render.run function
+ 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, NiceValue 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, NiceValue 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.Nice.Value as NiceValue+import LLVM.Extra.Nice.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, NiceValue.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/Main.hs view
@@ -0,0 +1,18 @@+module Main where++import qualified Test.Array as Array++import qualified LLVM.Core as LLVM++import Data.Tuple.HT (mapFst)++import qualified Test.QuickCheck as QC+++main :: IO ()+main = do+   LLVM.initializeNativeTarget++   mapM_ (\(msg,prop) -> putStr (msg++": ") >> prop >>= QC.quickCheck) $+      map (mapFst ("Array."++)) Array.tests +++      []
+ test/Test/Array.hs view
@@ -0,0 +1,101 @@+module Test.Array where++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.Nice.Value.Storable as Storable+import qualified LLVM.Extra.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value as NiceValue++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import Foreign.Storable (Storable)++import qualified Data.List.HT as ListHT+import Data.Int (Int32, Int64)++import Control.Applicative ((<$>))++import qualified Test.QuickCheck.Monadic as QCMon+import qualified Test.QuickCheck as QC+++type Dim = ComfortShape.ZeroBased Int64+type Dim2 = (Dim, Dim)++genArray :: (QC.Arbitrary a, Storable a) => QC.Gen (Array Dim2 a)+genArray = do+   m <- QC.choose (1,10)+   n <- QC.choose (1,10)+   let shape = (Shape.ZeroBased m, Shape.ZeroBased n)+   Array.fromList shape <$> QC.vector (ComfortShape.size shape)+++rowSumSymb ::+   (Shape.C sh0, Shape.C sh1, NiceValue.Additive a) =>+   Symb.Array (sh0,sh1) a -> Symb.Array sh0 a+rowSumSymb = Symb.fold1 Expr.add++columnSumSymb ::+   (Shape.C sh0, Shape.C sh1, NiceValue.Additive a) =>+   Symb.Array (sh0,sh1) a -> Symb.Array sh1 a+columnSumSymb = Symb.fold1 Expr.add . Slice.apply Slice.transpose+++getRows ::+   (ComfortShape.C sh0, ComfortShape.C sh1, Storable a) =>+   Array (sh0,sh1) a -> [[a]]+getRows x =+   ListHT.sliceVertical+      (ComfortShape.size $ snd $ Array.shape x)+      (Array.toList x)++rowPred ::+   (Num a, Eq a, Storable a,+    ComfortShape.C sh0, ComfortShape.C sh1) =>+   Array (sh0, sh1) a -> Array sh0 a -> Bool+rowPred x y  =  Array.toList y == map sum (getRows x)++columnPred ::+   (Num a, Eq a, Storable a,+    ComfortShape.C sh0, ComfortShape.C sh1) =>+   Array (sh0, sh1) a -> Array sh1 a -> Bool+columnPred x y  =  Array.toList y == foldl1 (zipWith (+)) (getRows x)++run ::+   (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) ->+   (Array sh0 a -> Array sh1 a -> Bool) ->+   IO QC.Property+run qcgen code predicate = do+   act <- Render.run code+   return $ QC.forAll qcgen $ \x ->+      QCMon.monadicIO $ do+         y <- QCMon.run $ act x+         QCMon.assert $ predicate x y+++tests :: [(String, IO QC.Property)]+tests =+   ("rowSum",+      run (genArray :: QC.Gen (Array Dim2 Int32)) rowSumSymb rowPred) :+   ("columnSum",+      run (genArray :: QC.Gen (Array Dim2 Int32)) columnSumSymb columnPred) :+   ("rowSumV3",+      run (genArray :: QC.Gen (Array Dim2 (LLVM.Vector TypeNum.D3 Int32)))+         rowSumSymb rowPred) :+   ("columnSumV3",+      run (genArray :: QC.Gen (Array Dim2 (LLVM.Vector TypeNum.D3 Int32)))+         columnSumSymb columnPred) :+   []