packages feed

knead 0.4.2 → 0.5

raw patch · 22 files changed

+941/−1759 lines, 22 filesdep +QuickCheckdep +fixed-lengthdep +kneaddep −storable-tupledep ~basedep ~comfort-arraydep ~llvm-extra

Dependencies added: QuickCheck, fixed-length, knead, llvm-dsl

Dependencies removed: storable-tuple

Dependency ranges changed: base, comfort-array, llvm-extra, llvm-tf, storable-record, tfp, utility-ht

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,5 +1,5 @@ Name:             knead-Version:          0.4.2+Version:          0.5 License:          BSD3 License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -45,11 +45,13 @@   like reshaping, collapsing a dimension and extruding another one. Tested-With:      GHC==7.4.2, GHC==7.8.4 Tested-With:      GHC==8.4.3, GHC==8.6.1-Cabal-Version:    >=1.6+Cabal-Version:    >=1.8 Build-Type:       Simple+Extra-Source-Files:+  Makefile  Source-Repository this-  Tag:         0.4.2+  Tag:         0.5   Type:        darcs   Location:    http://hub.darcs.net/thielema/knead/ @@ -59,17 +61,18 @@  Library   Build-Depends:-    llvm-extra >=0.8.1 && <0.9,-    llvm-tf >=3.1.1 && <3.2,+    llvm-dsl >=0.0 && <0.1,+    llvm-extra >=0.10 && <0.11,+    llvm-tf >=9.2 && <9.3,     tfp >=1.0 && <1.1,     comfort-array >=0.3 && <0.5,-    storable-tuple >=0.0 && <0.1,-    storable-record >=0.0.3 && <0.1,+    fixed-length >=0.2.1 && <0.3,+    storable-record >=0.0.5 && <0.1,     storable-enum >=0.0 && <0.1,     bool8 >=0.0 && <0.1,     transformers >=0.3 && <0.6,     tagged >=0.7 && <0.9,-    utility-ht >=0.0.1 && <0.1,+    utility-ht >=0.0.15 && <0.1,     prelude-compat >=0.0 && <0.0.1,     base >=4 && <5 @@ -79,7 +82,6 @@     Data.Array.Knead.Shape     Data.Array.Knead.Shape.Cubic     Data.Array.Knead.Shape.Cubic.Int-    Data.Array.Knead.Shape.Orphan     Data.Array.Knead.Expression     Data.Array.Knead.Expression.Vector     Data.Array.Knead.Parameter@@ -98,3 +100,21 @@     Data.Array.Knead.Parameterized.Private     Data.Array.Knead.Parameterized.PhysicalHull     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+  GHC-Options: -Wall+  Hs-Source-Dirs: test+  Main-Is: Main.hs+  Other-Modules:+    Test.Array
src/Data/Array/Knead/Code.hs view
@@ -4,56 +4,20 @@ import qualified Data.Array.Knead.Shape as Shape  import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Storable as Storable -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 Data.Functor.Compose (Compose(Compose))+import Foreign.Ptr (Ptr)  import Prelude2010 import Prelude ()   getElementPtr ::-   (Shape.C sh, Shape.Index sh ~ ix) =>+   (Shape.C sh, Shape.Index sh ~ ix, Storable.C a) =>    MultiValue.T sh -> LLVM.Value (Ptr a) ->    MultiValue.T ix ->    LLVM.CodeGenFunction r (LLVM.Value (Ptr a))-getElementPtr sh ptr ix = do-   n <- Shape.offset 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,490 +1,91 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-module Data.Array.Knead.Expression where--import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.FastMath as FastMath-import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C-import qualified LLVM.Core as LLVM-import LLVM.Extra.Multi.Value (PatternTuple, Decomposed, Atom, )--import qualified Control.Monad.HT as Monad--import qualified Data.Tuple.HT as TupleHT-import qualified Data.Tuple as Tuple-import Data.Complex (Complex((:+)))-import Data.Bool8 (Bool8)--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.lift f a)-   lift2 f (Exp a) (Exp b) = Exp (Monad.lift2 f a b)-   lift3 f (Exp a) (Exp b) (Exp c) = Exp (Monad.lift3 f a b c)-   lift4 f (Exp a) (Exp b) (Exp c) (Exp d) = Exp (Monad.lift4 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 (Monad.liftJoin2 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 (Monad.liftJoin3 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))----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 = liftM (MultiValue.mapFstF (unliftM1 f))--mapSnd :: (Exp b -> Exp c) -> Exp (a, b) -> Exp (a, c)-mapSnd f = liftM (MultiValue.mapSndF (unliftM1 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 = liftM (MultiValue.mapFst3F (unliftM1 f))--mapSnd3 :: (Exp b0 -> Exp b1) -> Exp (a,b0,c) -> Exp (a,b1,c)-mapSnd3 f = liftM (MultiValue.mapSnd3F (unliftM1 f))--mapThd3 :: (Exp c0 -> Exp c1) -> Exp (a,b,c0) -> Exp (a,b,c1)-mapThd3 f = liftM (MultiValue.mapThd3F (unliftM1 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'---boolPFrom8 :: Exp Bool8 -> Exp Bool-boolPFrom8 = lift1 MultiValue.boolPFrom8--bool8FromP :: Exp Bool -> Exp Bool8-bool8FromP = lift1 MultiValue.bool8FromP--intFromBool8 :: (MultiValue.NativeInteger i ir) => Exp Bool8 -> Exp i-intFromBool8 = liftM MultiValue.intFromBool8--floatFromBool8 :: (MultiValue.NativeFloating a ar) => Exp Bool8 -> Exp a-floatFromBool8 = liftM MultiValue.floatFromBool8---fromFastMath :: Exp (FastMath.Number flags a) -> Exp a-fromFastMath = lift1 FastMath.mvDenumber--toFastMath :: Exp a -> Exp (FastMath.Number flags a)-toFastMath = lift1 FastMath.mvNumber---minBound, maxBound :: (MultiValue.Bounded a) => Exp a-minBound = lift0 MultiValue.minBound-maxBound = lift0 MultiValue.maxBound---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---min, max :: (MultiValue.Real a) => Exp a -> Exp a -> Exp a-min = liftM2 A.min-max = liftM2 A.max---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,+   liftTupleM,+   liftTupleM2,+   liftTupleM3,+   zip,+   zip3,+   zip4,+   unzip,+   unzip3,+   unzip4,+   fst,+   snd,+   mapFst,+   mapSnd,+   mapPair,+   swap,+   curry,+   uncurry,+   fst3,+   snd3,+   thd3,+   mapFst3,+   mapSnd3,+   mapThd3,+   mapTriple,+   tuple,+   untuple,+   modifyMultiValue,+   modifyMultiValue2,+   modifyMultiValueM,+   modifyMultiValueM2,+   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/Parameter.hs view
@@ -1,224 +1,3 @@-{-# 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, )--import Prelude2010-import Prelude ()---{- |-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.--}-{-# INLINE withTuple #-}-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--{-# INLINE withMulti #-}-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--{-# INLINE with #-}-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+module Data.Array.Knead.Parameter (Param.T) where -instance Fractional a => Fractional (T p a) where-   (/) = liftA2 (/)-   fromRational = pure . fromRational+import qualified LLVM.DSL.Parameter as Param
src/Data/Array/Knead/Parameterized/Physical.hs view
@@ -6,6 +6,7 @@    Phys.fromList,    feed,    the,+   theMarshal,    render,    renderShape,    mapAccumLSimple,@@ -19,24 +20,25 @@ 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.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 Data.Array.Knead.Code (getElementPtr)  import qualified Data.Array.Comfort.Storable.Unchecked as Array -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory+import qualified LLVM.DSL.Parameter as Param+import qualified LLVM.DSL.Execution as Code+import LLVM.DSL.Expression (Exp, unExp)+ import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Storable as Storable+import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory  import qualified LLVM.Core as LLVM -import Foreign.Marshal.Utils (with, ) import Foreign.Marshal.Alloc (alloca, )-import Foreign.Storable (Storable, peek, )+import Foreign.Storable (peek, ) import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, ) import Foreign.Ptr (FunPtr, Ptr, ) @@ -48,8 +50,7 @@  {-# INLINE feed #-} feed ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    MultiValueMemory.C a) =>+   (Shape.C sh, Marshal.MV sh, Storable.C a) =>    Param.T p (Phys.Array sh a) -> Sym.Array p sh a feed arr =    Param.withMulti (fmap Array.shape arr) $ \getShape valueShape ->@@ -58,85 +59,105 @@          case mapFst valueShape $ MultiValue.unzip p of             (sh, MultiValue.Cons ptr) ->                Core.Array (Expr.lift0 sh) $-                  Memory.load <=< getElementPtr sh ptr)+                  Storable.loadMultiValue <=< getElementPtr sh ptr)       (\p ->          case Array.buffer $ Param.get arr p of             fptr ->                withForeignPtr fptr $ \ptr ->-                  return (fptr, (getShape p, MultiValueMemory.castStructPtr ptr)))+                  return (fptr, (getShape p, ptr)))       touchForeignPtr   type Importer f = FunPtr f -> f  foreign import ccall safe "dynamic" callThe ::-   Importer (Ptr param -> Ptr am -> IO ())+   Importer (LLVM.Ptr param -> Ptr a -> IO ())   the ::-   (Shape.Scalar z, MultiValueMemory.C a, Storable a) =>+   (Shape.Scalar z, Storable.C a, MultiValue.C a) =>    Sym.Array p z a -> IO (p -> IO a) the (Sym.Array arr create delete) = do    func <--      compile "the" $+      Code.compile "the" $       Code.createFunction callThe "eval" $       \paramPtr resultPtr -> do          param <- Memory.load paramPtr          case arr param of             Core.Array z code ->-               code (Shape.zeroIndex z) >>= flip Memory.store resultPtr+               code (Shape.zeroIndex z) >>=+               flip Storable.storeMultiValue 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+      Marshal.with param $ \pptr ->+      alloca $ \aptr -> func pptr aptr >> peek aptr +foreign import ccall safe "dynamic" callTheMarshal ::+   Importer (LLVM.Ptr param -> LLVM.Ptr a -> IO ()) +theMarshal ::+   (Shape.Scalar z, Marshal.C a, MultiValue.C a) =>+   Sym.Array p z a -> IO (p -> IO a)+theMarshal (Sym.Array arr create delete) = do+   func <-+      Code.compile "the-marshal" $+      Code.createFunction callTheMarshal "eval" $+      \paramPtr resultPtr -> do+         param <- Memory.load paramPtr+         case arr param of+            Core.Array z code ->+               code (Shape.zeroIndex z) >>=+               flip Memory.store resultPtr+         LLVM.ret ()+   return $ \p ->+      bracket (create p) (delete . fst) $ \(_ctx, param) ->+      Marshal.with param $ \pptr ->+      Marshal.alloca $ \aptr ->+         func pptr aptr >>+         Marshal.peek aptr++ foreign import ccall safe "dynamic" callShaper ::-   Importer (Ptr param -> Ptr shape -> IO Shape.Size)+   Importer (LLVM.Ptr param -> LLVM.Ptr shape -> IO Shape.Size)   renderShape ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>+   (Shape.C sh, Marshal.MV sh,+    Storable.C a, MultiValue.C a) =>    Sym.Array p sh a -> IO (p -> IO (sh, Shape.Size)) renderShape (Sym.Array arr create delete) = do    fsh <--      compile "renderShape" $+      Code.compile "renderShape" $       Code.createFunction callShaper "shape" $       \paramPtr resultPtr -> do         param <- Memory.load paramPtr         case arr param of            Core.Array esh _code -> do               sh <- unExp esh-              MultiValueMemory.store sh resultPtr+              Memory.store sh resultPtr               Shape.size 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+      Marshal.alloca $ \shptr ->+      Marshal.with param $ \pptr -> do+         n <- fsh pptr shptr+         sh <- Marshal.peek shptr          return (sh, n)   render ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>+   (Shape.C sh, Marshal.MV sh, Storable.C a) =>    Sym.Array p sh a -> IO (p -> IO (Phys.Array sh a)) render = PhysHull.render . Sym.arrayHull   mapAccumLSimple ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,     MultiValue.C acc,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>+    Storable.C a, MultiValue.C a,+    Storable.C b, MultiValue.C b) =>    (Exp acc -> Exp a -> Exp (acc,b)) ->    Sym.Array p sh acc ->    Sym.Array p (sh, n) a ->@@ -148,9 +169,9 @@          (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) =>+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,+    Storable.C a, MultiValue.C a) =>    (Exp a -> Exp b -> Exp a) ->    Sym.Array p sh a ->    Sym.Array p (n,sh) b ->@@ -163,9 +184,8 @@  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) =>+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    Storable.C a, MultiValue.C a) =>    (Exp a -> Exp a -> Exp a) ->    Sym.Array p sh1 a ->    Sym.Array p sh0 (ix1, a) -> IO (p -> IO (Phys.Array sh1 a))@@ -177,9 +197,8 @@  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) =>+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    Storable.C a, MultiValue.C a) =>    (Exp a -> Exp a -> Exp a) ->    Sym.Array p sh1 a ->    Sym.Array p sh0 (Maybe (ix1, a)) -> IO (p -> IO (Phys.Array sh1 a))@@ -191,9 +210,8 @@  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) =>+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    Storable.C a, MultiValue.C a) =>    (Exp a -> Exp a -> Exp a) ->    Sym.Array p sh1 a ->    (Exp ix0 -> Exp ix1) ->
src/Data/Array/Knead/Parameterized/PhysicalHull.hs view
@@ -27,20 +27,21 @@ import qualified Data.Array.Knead.Simple.Private as Core import qualified Data.Array.Knead.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 (compile, )+import Data.Array.Knead.Simple.PhysicalPrivate (MarshalPtr)  import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory+import qualified LLVM.DSL.Execution as Code+import LLVM.DSL.Expression (Exp, unExp)+ import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Storable as Storable+import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A  import qualified LLVM.Core as LLVM -import Foreign.Marshal.Utils (with, ) import Foreign.Marshal.Array (allocaArray, ) import Foreign.Marshal.Alloc (alloca, ) import Foreign.Storable (Storable, peek, peekElemOff, )@@ -55,20 +56,15 @@ mallocArray :: (Storable a) => Shape.Size -> IO (ForeignPtr a) mallocArray = mallocForeignPtrArray . fromIntegral -withForeignMemPtr ::-   ForeignPtr a -> (Ptr (MultiValueMemory.Struct a) -> IO b) -> IO b-withForeignMemPtr fptr act =-   withForeignPtr fptr $ act . MultiValueMemory.castStructPtr - type Importer f = FunPtr f -> f   foreign import ccall safe "dynamic" callShaper ::-   Importer (Ptr param -> Ptr shape -> IO Shape.Size)+   Importer (LLVM.Ptr param -> LLVM.Ptr shape -> IO Shape.Size)  foreign import ccall safe "dynamic" callFill ::-   Importer (Ptr param -> Ptr shape -> Ptr am -> IO ())+   Importer (LLVM.Ptr param -> LLVM.Ptr shape -> Ptr a -> IO ())   {-@@ -77,24 +73,22 @@ An example is 'mapFilter'. -} materialize ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>+   (Shape.C sh, Marshal.MV sh, Storable.C a) =>    String ->    (core -> Exp sh) ->    (core ->-    LLVM.Value (Ptr (MultiValueMemory.Struct sh)) ->-    LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->+    LLVM.Value (MarshalPtr sh) -> LLVM.Value (Ptr a) ->     LLVM.CodeGenFunction () ()) ->    Sym.Hull p core -> IO (p -> IO (Array sh a)) materialize name shape fill (Sym.Hull core create delete) = do    (fsh, farr) <--      compile name $+      Code.compile name $       liftA2 (,)          (Code.createFunction callShaper "shape" $           \paramPtr resultPtr -> do             param <- Memory.load paramPtr             sh <- unExp $ shape $ core param-            MultiValueMemory.store sh resultPtr+            Memory.store sh resultPtr             Shape.size sh >>= LLVM.ret)          (Code.createFunction callFill "fill" $           \paramPtr shapePtr bufferPtr -> do@@ -104,41 +98,37 @@     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-         fptr <- mallocArray =<< fsh paramMVPtr shapeMVPtr-         withForeignMemPtr fptr $ farr paramMVPtr shapeMVPtr-         sh <- peek shptr+      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 (Ptr param -> Ptr final -> Ptr shape -> Ptr am -> IO ())+   Importer (LLVM.Ptr param -> Ptr final -> LLVM.Ptr shape -> Ptr a -> IO ())   materializeExpArray ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>+   (Shape.C sh, Marshal.MV sh, Storable.C a, Storable.C b) =>    String ->    (core -> Exp sh) ->    (core ->-    LLVM.Value (Ptr (MultiValueMemory.Struct b)) ->-    LLVM.Value (Ptr (MultiValueMemory.Struct sh)) ->-    LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->+    LLVM.Value (Ptr b) ->+    LLVM.Value (MarshalPtr sh) ->+    LLVM.Value (Ptr a) ->     LLVM.CodeGenFunction () ()) ->    Sym.Hull p core -> IO (p -> IO (b, Array sh a)) materializeExpArray name shape fill (Sym.Hull core create delete) = do    (fsh, farr) <--      compile name $+      Code.compile name $       liftA2 (,)          (Code.createFunction callShaper "shape" $           \paramPtr resultPtr -> do             param <- Memory.load paramPtr             sh <- unExp $ shape $ core param-            MultiValueMemory.store sh resultPtr+            Memory.store sh resultPtr             Shape.size sh >>= LLVM.ret)          (Code.createFunction callFillExpArray "fill" $           \paramPtr finalPtr shapePtr bufferPtr -> do@@ -148,50 +138,48 @@     return $ \p ->       bracket (create p) (delete . fst) $ \(_ctx, param) ->-      alloca $ \shptr ->+      Marshal.alloca $ \shptr ->       alloca $ \finalPtr ->-      with param $ \paramPtr -> do-         let paramMVPtr = MultiValueMemory.castStructPtr paramPtr-         let finalMVPtr = MultiValueMemory.castStructPtr finalPtr-         let shapeMVPtr = MultiValueMemory.castStructPtr shptr-         fptr <- mallocArray =<< fsh paramMVPtr shapeMVPtr-         withForeignMemPtr fptr $ farr paramMVPtr finalMVPtr shapeMVPtr-         sh <- peek shptr+      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 (Ptr param -> Ptr shapeA -> Ptr shapeB -> Ptr Shape.Size -> IO ())+   Importer+      (LLVM.Ptr param ->+       LLVM.Ptr shapeA -> LLVM.Ptr shapeB -> Ptr Shape.Size -> IO ())  foreign import ccall safe "dynamic" callFill2 ::-   Importer (Ptr param -> Ptr shapeA -> Ptr am -> Ptr shapeB -> Ptr bm -> IO ())+   Importer+      (LLVM.Ptr param ->+       LLVM.Ptr shapeA -> Ptr a -> LLVM.Ptr shapeB -> Ptr b -> IO ())   materialize2 ::-   (Shape.C sha, Storable sha, MultiValueMemory.C sha,-    Shape.C shb, Storable shb, MultiValueMemory.C shb,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>+   (Shape.C sha, Marshal.MV sha,+    Shape.C shb, Marshal.MV shb,+    Storable.C a, Storable.C b) =>    String ->    (core -> Exp (sha,shb)) ->    (core ->-    (LLVM.Value (Ptr (MultiValueMemory.Struct sha)),-     LLVM.Value (Ptr (MultiValueMemory.Struct a))) ->-    (LLVM.Value (Ptr (MultiValueMemory.Struct shb)),-     LLVM.Value (Ptr (MultiValueMemory.Struct b))) ->+    (LLVM.Value (MarshalPtr sha), LLVM.Value (Ptr a)) ->+    (LLVM.Value (MarshalPtr shb), LLVM.Value (Ptr b)) ->     LLVM.CodeGenFunction () ()) ->    Sym.Hull p core -> IO (p -> IO (Array sha a, Array shb b)) materialize2 name shape fill (Sym.Hull core create delete) = do    (fsh, farr) <--      compile name $+      Code.compile name $       liftA2 (,)          (Code.createFunction callShaper2 "shape" $           \paramPtr shapeAPtr shapeBPtr sizesPtr -> do             param <- Memory.load paramPtr             (sha,shb) <- fmap MultiValue.unzip $ unExp $ shape $ core param-            MultiValueMemory.store sha shapeAPtr-            MultiValueMemory.store shb shapeBPtr+            Memory.store sha shapeAPtr+            Memory.store shb shapeBPtr             sizeAPtr <- LLVM.bitcast sizesPtr             flip LLVM.store sizeAPtr =<< Shape.size sha             sizeBPtr <- A.advanceArrayElementPtr sizeAPtr@@ -205,35 +193,29 @@     return $ \p ->       bracket (create p) (delete . fst) $ \(_ctx, param) ->-      alloca $ \shaPtr ->-      alloca $ \shbPtr ->+      Marshal.alloca $ \shaPtr ->+      Marshal.alloca $ \shbPtr ->       allocaArray 2 $ \sizesPtr ->-      with param $ \paramPtr -> do-         let paramMVPtr = MultiValueMemory.castStructPtr paramPtr-         let shapeAMVPtr = MultiValueMemory.castStructPtr shaPtr-         let shapeBMVPtr = MultiValueMemory.castStructPtr shbPtr-         fsh paramMVPtr shapeAMVPtr shapeBMVPtr sizesPtr+      Marshal.with param $ \paramPtr -> do+         fsh paramPtr shaPtr shbPtr sizesPtr          afptr <- mallocArray =<< peekElemOff sizesPtr 0          bfptr <- mallocArray =<< peekElemOff sizesPtr 1-         withForeignMemPtr afptr $ \aptr ->-            withForeignMemPtr bfptr $ \bptr ->-            farr paramMVPtr shapeAMVPtr aptr shapeBMVPtr bptr-         sha <- peek shaPtr-         shb <- peek shbPtr+         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,-    Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>+   (Shape.C sh, Shape.Index sh ~ ix, Marshal.MV sh,+    Storable.C a) =>    Sym.Hull p (Core.Array sh a) -> IO (p -> IO (Array sh a)) render =    materialize "render" Core.shape       (\(Core.Array esh code) shapePtr bufferPtr -> do-         let step ix p = do-                flip Memory.store p =<< code ix-                A.advanceArrayElementPtr p+         let step ix p = flip Storable.storeNextMultiValue p =<< code ix          sh <- Shape.load esh shapePtr          void $ Shape.loop step sh bufferPtr) @@ -247,9 +229,8 @@  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) =>+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    Storable.C a) =>    Sym.Hull p (Scatter sh0 sh1 a) -> IO (p -> IO (Array sh1 a)) scatter =    materialize "scatter"@@ -268,9 +249,8 @@  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) =>+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    Storable.C a) =>    Sym.Hull p (ScatterMaybe sh0 sh1 a) -> IO (p -> IO (Array sh1 a)) scatterMaybe =    materialize "scatterMaybe"@@ -287,11 +267,9 @@    }  mapAccumLSimple ::-   (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) =>+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,+    MultiValue.C acc, Storable.C a, Storable.C b) =>    Sym.Hull p (MapAccumLSimple sh n acc a b) -> IO (p -> IO (Array (sh,n) b)) mapAccumLSimple =    materialize "mapAccumLSimple"@@ -310,11 +288,9 @@  -- FIXME: check correct size of array of initial values mapAccumLSequence ::-   (Shape.C n, Storable n, MultiValueMemory.C n,-    MultiValue.C acc,-    Storable final, MultiValueMemory.C final,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>+   (Shape.C n, Marshal.MV n, MultiValue.C acc,+    Storable.C final, MultiValue.C final,+    Storable.C a, Storable.C b) =>    Sym.Hull p (MapAccumLSequence n acc final a b) ->    IO (p -> IO (final, Array n b)) mapAccumLSequence =@@ -334,12 +310,11 @@  -- FIXME: check correct size of array of initial values mapAccumL ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,     MultiValue.C acc,-    Storable final, MultiValueMemory.C final,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>+    Storable.C final, MultiValue.C final,+    Storable.C a, Storable.C b) =>    Sym.Hull p (MapAccumL sh n acc final a b) ->    IO (p -> IO (Array sh final, Array (sh,n) b)) mapAccumL =@@ -361,9 +336,9 @@  -- FIXME: check correct size of array of initial values foldOuterL ::-   (Shape.C n, Storable n, MultiValueMemory.C n,-    Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>+   (Shape.C n, Marshal.MV n,+    Shape.C sh, Marshal.MV sh,+    Storable.C a) =>    Sym.Hull p (FoldOuterL n sh a b) -> IO (p -> IO (Array sh a)) foldOuterL =    materialize "foldOuterL"@@ -379,15 +354,13 @@    }  mapFilter ::-   (Shape.Sequence n,-    Storable n, MultiValueMemory.C n,-    Storable b, MultiValueMemory.C b) =>+   (Shape.Sequence n, Marshal.MV n, Storable.C b) =>    Sym.Hull p (MapFilter n a b) -> IO (p -> IO (Array n b)) mapFilter =    materialize "mapFilter"       (Core.shape . mapFilterArray)       (\(MapFilter f p arr) shapePtr bufferPtr ->-         flip MultiValueMemory.store shapePtr+         flip Memory.store shapePtr             =<< Priv.mapFilter f p arr shapePtr bufferPtr)  @@ -399,15 +372,15 @@  -- FIXME: check correct size of row selection array filterOuter ::-   (Shape.Sequence n, Storable n, MultiValueMemory.C n,-    Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>+   (Shape.Sequence n, Marshal.MV n,+    Shape.C sh, Marshal.MV sh,+    Storable.C a) =>    Sym.Hull p (FilterOuter n sh a) -> IO (p -> IO (Array (n,sh) a)) filterOuter =    materialize "filterOuter"       (Core.shape . filterOuterArray)       (\(FilterOuter p arr) shapePtr bufferPtr ->-         flip MultiValueMemory.store shapePtr+         flip Memory.store shapePtr             =<< Priv.filterOuter p arr shapePtr bufferPtr)  @@ -419,9 +392,9 @@    }  addDimension ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    Storable b, MultiValueMemory.C b) =>+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,+    Storable.C b) =>    Sym.Hull p (AddDimension sh n a b) -> IO (p -> IO (Array (sh,n) b)) addDimension =    materialize "addDimension"
src/Data/Array/Knead/Parameterized/Private.hs view
@@ -4,18 +4,20 @@  import qualified Data.Array.Knead.Simple.Symbolic as Core -import qualified Data.Array.Knead.Parameter as Param import qualified Data.Array.Knead.Shape as Shape import qualified Data.Array.Knead.Expression as Expr import Data.Array.Knead.Expression (Exp, ) -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory-import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.DSL.Parameter as Param -import Foreign.Storable (Storable, )+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Marshal as Marshal +import Control.Monad (liftM2) import Control.Applicative (Applicative (pure, (<*>)), ) +import Data.Tuple.Strict (zipPair)+ import Prelude2010 hiding (id, map, zipWith, replicate) import Prelude () @@ -24,7 +26,7 @@ -- 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) =>+   (Marshal.MV parameter) =>    Array {       core :: MultiValue.T parameter -> Core.Array sh a,       createContext :: p -> IO (context, parameter),@@ -36,16 +38,14 @@    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))+         (MultiValue.uncurry $ \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.C sh, Shape.Index sh ~ ix, Marshal.MV ix,     Shape.Scalar z) =>    Array p sh a -> Param.T p ix -> Array p z a (!) arr pix =@@ -57,17 +57,14 @@   fill ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>+   (Shape.C sh, Marshal.MV sh, Marshal.MV 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))+      (MultiValue.uncurry $ \vsh va ->+         Core.fill (valueSh vsh) (Expr.lift0 $ valueA va))       (createPlain $ \p -> (getSh p, getA p))       deletePlain @@ -81,7 +78,7 @@   id ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh, Shape.Index sh ~ ix) =>+   (Shape.C sh, Marshal.MV sh, Shape.Index sh ~ ix) =>    Param.T p sh -> Array p sh ix id sh =    Shape.paramWith sh $ \getSh valueSh ->@@ -91,35 +88,32 @@       deletePlain  map ::-   (Shape.C sh, MultiValueMemory.C c, Storable c) =>+   (Shape.C sh, Marshal.MV 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) =>+   (Shape.C sh, Marshal.MV 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) =>+   (Shape.C sh0, Shape.C sh1, Marshal.MV 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) =>+   (Shape.C sh, Shape.Scalar z, Marshal.MV c, MultiValue.C a) =>    (Exp c -> Exp a -> Exp a -> Exp a) ->    Param.T p c -> Array p sh a -> Array p z a fold1All = lift (\p -> Core.fill Shape.scalar . Core.fold1All p)  lift ::-   (Shape.C sh0, Shape.C sh1,-    MultiValueMemory.C c, Storable c) =>+   (Shape.C sh0, Shape.C sh1, Marshal.MV 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@@ -133,7 +127,7 @@  data Hull p a =    forall parameter context.-   (Storable parameter, MultiValueMemory.C parameter) =>+   (Marshal.MV parameter) =>    Hull {       hullCore :: MultiValue.T parameter -> a,       hullCreateContext :: p -> IO (context, parameter),@@ -147,7 +141,7 @@    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)+         (MultiValue.uncurry $ \a b -> arrA a $ arrB b)          (combineCreate createA createB)          (combineDelete deleteA deleteB) @@ -161,9 +155,8 @@    case tunnel of       Param.Tunnel getSl valueSl ->          Hull-            (\p ->-               case MultiValue.unzip p of-                  (arrp, sl) -> f (Expr.lift0 $ valueSl sl) $ arr arrp)+            (MultiValue.uncurry $ \arrp sl ->+               f (Expr.lift0 $ valueSl sl) $ arr arrp)             (\p -> do                (ctx, param) <- create p                return (ctx, (param, getSl p)))@@ -189,8 +182,7 @@   -expParam ::-   (Storable a, MultiValueMemory.C a) => Param.T p a -> Param.Tunnel p a+expParam :: (Marshal.MV a) => Param.T p a -> Param.Tunnel p a expParam = Param.tunnel MultiValue.cons  @@ -207,10 +199,8 @@    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))+combineCreate createA createB p =+   liftM2 zipPair (createA p) (createB p)  {-# INLINE combineDelete #-} combineDelete ::
src/Data/Array/Knead/Parameterized/Render.hs view
@@ -4,6 +4,7 @@ -} module Data.Array.Knead.Parameterized.Render (    run,+   MarshalExp(..),    MapFilter(..),    FilterOuter(..),    Scatter(..),@@ -20,7 +21,6 @@ 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.Shape as Shape import Data.Array.Knead.Parameterized.PhysicalHull          (MapFilter, FilterOuter,@@ -28,10 +28,11 @@           Scatter, ScatterMaybe, AddDimension) 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.DSL.Parameter as Param -import Foreign.Storable (Storable, )+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Storable as Storable+import qualified LLVM.Extra.Marshal as Marshal  import Control.Arrow (arr, ) import Control.Applicative (liftA2, liftA3, pure, (<*>), )@@ -48,89 +49,87 @@    build :: Sym.Hull p f -> IO (p -> Plain f)  instance-   (MultiValueMemory.C sh, Storable sh, Shape.C sh,-    MultiValueMemory.C a, Storable a) =>+   (Marshal.MV sh, Shape.C sh, Storable.C a) =>       C (Core.Array sh a) where    type Plain (Core.Array sh a) = IO (Phys.Array sh a)    build = PhysHullP.render  instance-   (Shape.Sequence n,-    Storable n, MultiValueMemory.C n,-    Storable b, MultiValueMemory.C b) =>+   (Shape.Sequence n, Marshal.MV n,+    Storable.C b, MultiValue.C b) =>       C (MapFilter n a b) where    type Plain (MapFilter n a b) = IO (Phys.Array n b)    build = PhysHullP.mapFilter  instance-   (Shape.Sequence n, Storable n, MultiValueMemory.C n,-    Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>+   (Shape.Sequence n, Marshal.MV n,+    Shape.C sh, Marshal.MV sh,+    Storable.C a, MultiValue.C a) =>       C (FilterOuter n sh a) where    type Plain (FilterOuter n sh a) = IO (Phys.Array (n,sh) a)    build = PhysHullP.filterOuter  instance-   (MultiValueMemory.C sh0, Storable sh0, Shape.C sh0,-    MultiValueMemory.C sh1, Storable sh1, Shape.C sh1,-    MultiValueMemory.C a, Storable a) =>+   (Shape.C sh0, Marshal.MV sh0,+    Shape.C sh1, Marshal.MV sh1,+    Storable.C a, MultiValue.C a) =>       C (Scatter sh0 sh1 a) where    type Plain (Scatter sh0 sh1 a) = IO (Phys.Array sh1 a)    build = PhysHullP.scatter  instance-   (MultiValueMemory.C sh0, Storable sh0, Shape.C sh0,-    MultiValueMemory.C sh1, Storable sh1, Shape.C sh1,-    MultiValueMemory.C a, Storable a) =>+   (Shape.C sh0, Marshal.MV sh0,+    Shape.C sh1, Marshal.MV sh1,+    Storable.C a, MultiValue.C a) =>       C (ScatterMaybe sh0 sh1 a) where    type Plain (ScatterMaybe sh0 sh1 a) = IO (Phys.Array sh1 a)    build = PhysHullP.scatterMaybe  instance-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,     MultiValue.C acc,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>+    Storable.C a, MultiValue.C a,+    Storable.C b, MultiValue.C b) =>       C (MapAccumLSimple sh n acc a b) where    type Plain (MapAccumLSimple sh n acc a b) = IO (Phys.Array (sh,n) b)    build = PhysHullP.mapAccumLSimple  instance-   (Shape.C n, Storable n, MultiValueMemory.C n,+   (Shape.C n, Marshal.MV n,     MultiValue.C acc,-    Storable final, MultiValueMemory.C final,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>+    Storable.C final, MultiValue.C final,+    Storable.C a, MultiValue.C a,+    Storable.C b, MultiValue.C b) =>       C (MapAccumLSequence n acc final a b) where    type Plain (MapAccumLSequence n acc final a b) = IO (final, Phys.Array n b)    build = PhysHullP.mapAccumLSequence  instance-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,     MultiValue.C acc,-    Storable final, MultiValueMemory.C final,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>+    Storable.C final, MultiValue.C final,+    Storable.C a, MultiValue.C a,+    Storable.C b, MultiValue.C b) =>       C (MapAccumL sh n acc final a b) where    type Plain (MapAccumL sh n acc final a b) =             IO (Phys.Array sh final, Phys.Array (sh,n) b)    build = PhysHullP.mapAccumL  instance-   (Shape.C n, Storable n, MultiValueMemory.C n,-    Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a,-    Storable b, MultiValueMemory.C b) =>+   (Shape.C n, Marshal.MV n,+    Shape.C sh, Marshal.MV sh,+    Storable.C a, MultiValue.C a,+    Storable.C b, MultiValue.C b) =>       C (FoldOuterL n sh a b) where    type Plain (FoldOuterL n sh a b) = IO (Phys.Array sh a)    build = PhysHullP.foldOuterL  instance-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    Storable b, MultiValueMemory.C b) =>+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,+    Storable.C b, MultiValue.C b) =>       C (AddDimension sh n a b) where    type Plain (AddDimension sh n a b) = IO (Phys.Array (sh,n) b)    build = PhysHullP.addDimension@@ -139,10 +138,16 @@ singleton :: Exp a -> Core.Array () a singleton = Core.fromScalar -instance (MultiValueMemory.C a, Storable a) => C (Exp a) where+instance (Storable.C a, MultiValue.C a) => C (Exp a) where    type Plain (Exp a) = IO a    build = PhysP.the . Sym.runHull . fmap singleton +newtype MarshalExp a = MarshalExp {getMarshalExp :: Exp a}++instance (Marshal.C a, MultiValue.C a) => C (MarshalExp a) where+   type Plain (MarshalExp a) = IO a+   build = PhysP.theMarshal . Sym.runHull . fmap (singleton . getMarshalExp)+ instance (Argument arg, C func) => C (arg -> func) where    type Plain (arg -> func) = PlainArg arg -> Plain func    build f = fmap curry $ build $ Sym.extendHull fst f <*> buildArg (arr snd)@@ -153,12 +158,12 @@    buildArg :: Param.T p (PlainArg arg) -> Sym.Hull p arg  instance-   (MultiValueMemory.C sh, Storable sh, Shape.C sh, MultiValueMemory.C a) =>+   (Shape.C sh, Marshal.MV sh, Storable.C a) =>       Argument (Core.Array sh a) where    type PlainArg (Core.Array sh a) = Phys.Array sh a    buildArg = Sym.arrayHull . PhysP.feed -instance (MultiValueMemory.C a, Storable a) => Argument (Exp a) where+instance (Marshal.MV a) => Argument (Exp a) where    type PlainArg (Exp a) = a    buildArg = Sym.expHull . Sym.expParam @@ -179,11 +184,10 @@   _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) =>+   (Marshal.MV x,+    Shape.C sha, Marshal.MV sha, Storable.C a,+    Shape.C shb, Marshal.MV shb, Storable.C b,+    Shape.C shc, Marshal.MV shc, Storable.C c) =>    (Exp x -> Core.Array sha a -> Core.Array shb b -> Core.Array shc c) ->    IO (x -> Phys.Array sha a -> Phys.Array shb b -> IO (Phys.Array shc c)) _example f =
src/Data/Array/Knead/Parameterized/Slice.hs view
@@ -3,7 +3,7 @@ module Data.Array.Knead.Parameterized.Slice (    T,    apply,-   Linear,+   Cubic,    passAny,    pass,    pick,@@ -17,17 +17,18 @@ import qualified Data.Array.Knead.Simple.Slice as Slice import qualified Data.Array.Knead.Simple.Private as Core -import qualified Data.Array.Knead.Shape.Cubic as Linear+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.Parameter as Param import qualified Data.Array.Knead.Expression as Expr import Data.Array.Knead.Expression (Exp, )-import Data.Array.Knead.Shape.Cubic ((:.), ) -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory+import qualified LLVM.DSL.Parameter as Param+ import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Marshal as Marshal -import Foreign.Storable (Storable, )+import qualified Type.Data.Num.Unary as Unary   {-@@ -36,7 +37,7 @@ -} data T p sh0 sh1 =    forall parameter context.-   (Storable parameter, MultiValueMemory.C parameter) =>+   (Marshal.MV parameter) =>    Cons {       _core :: MultiValue.T parameter -> Slice.T sh0 sh1,       _createContext :: p -> IO (context, parameter),@@ -50,52 +51,49 @@    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))+      (MultiValue.uncurry $ \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)+type Cubic p rank0 rank1 = T p (Cubic.Shape rank0) (Cubic.Shape rank1)  -passAny :: Linear p sh sh+passAny :: Cubic p rank rank passAny =    Cons (const Slice.passAny) (Priv.createPlain $ const ()) Priv.deletePlain  pass ::-   Linear p sh0 sh1 ->-   Linear p (sh0:.i) (sh1:.i)+   (Unary.Natural rank0, Unary.Natural rank1) =>+   Cubic p rank0 rank1 ->+   Cubic p (Unary.Succ rank0) (Unary.Succ rank1) pass (Cons slice create delete) = Cons (Slice.pass . slice) create delete  pick ::-   (MultiValueMemory.C i, Storable i) =>-   Param.T p i ->-   Linear p sh0 sh1 ->-   Linear p (sh0:.i) sh1+   (Unary.Natural rank0, Unary.Natural rank1) =>+   Param.T p Index.Int ->+   Cubic p rank0 rank1 ->+   Cubic p (Unary.Succ rank0) rank1 pick = lift Slice.pick  extrude ::-   (MultiValueMemory.C i, Storable i) =>-   Param.T p i ->-   Linear p sh0 sh1 ->-   Linear p sh0 (sh1:.i)+   (Unary.Natural rank0, Unary.Natural rank1) =>+   Param.T p Index.Int ->+   Cubic p rank0 rank1 ->+   Cubic p rank0 (Unary.Succ rank1) extrude = lift Slice.extrude  lift ::-   (MultiValueMemory.C i, Storable i) =>-   (Exp i -> Slice.Linear sh0 sh1 -> Slice.Linear sh2 sh3) ->+   (Marshal.MV i) =>+   (Exp i -> Slice.Cubic rank0 rank1 -> Slice.Cubic rank2 rank3) ->    Param.T p i ->-   Linear p sh0 sh1 -> Linear p sh2 sh3+   Cubic p rank0 rank1 -> Cubic p rank2 rank3 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))+      (MultiValue.uncurry $ \slicep ip ->+         f (Expr.lift0 (valueI ip)) (slice slicep))       (\p -> do          (ctx, param) <- create p          return (ctx, (param, getI p)))
src/Data/Array/Knead/Parameterized/Symbolic.hs view
@@ -23,14 +23,13 @@ import Data.Array.Knead.Parameterized.Private (Array, gather, )  import qualified Data.Array.Knead.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 qualified LLVM.DSL.Parameter as Param -import Foreign.Storable (Storable, )+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Marshal as Marshal  import Control.Applicative ((<*>), ) @@ -47,8 +46,7 @@  backpermute ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,-    Shape.C sh1, Shape.Index sh1 ~ ix1,-    Storable sh1, MultiValueMemory.C sh1,+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,     MultiValue.C a) =>    Param.T p sh1 ->    (Exp ix1 -> Exp ix0) ->@@ -58,7 +56,7 @@   zipWith ::-   (Shape.C sh, MultiValueMemory.C d, Storable d) =>+   (Shape.C sh, Marshal.MV 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 =@@ -66,14 +64,14 @@   withExp ::-   (Storable x, MultiValueMemory.C x) =>+   (Marshal.MV 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) =>+   (Marshal.MV 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 =@@ -82,7 +80,7 @@      <*> Sym.arrayHull b  withExp3 ::-   (Storable x, MultiValueMemory.C x) =>+   (Marshal.MV x) =>    (Exp x -> Core.Array sha a ->     Core.Array shb b -> Core.Array shc c -> Core.Array shd d) ->    Param.T p x -> Array p sha a ->
src/Data/Array/Knead/Shape.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Data.Array.Knead.Shape (@@ -22,7 +22,6 @@    ) where  import qualified Data.Array.Knead.Expression as Expr-import qualified Data.Array.Knead.Parameter as Param import Data.Array.Knead.Shape.Orphan          (zeroBased, zeroBasedSize,           singletonRange, unzipRange, singletonShifted, unzipShifted)@@ -34,24 +33,24 @@           Enumeration(Enumeration)) import Data.Ix (Ix) -import qualified LLVM.Extra.Multi.Value.Memory as MultiMem+import qualified LLVM.DSL.Parameter as Param+ import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Multi.Iterator as IterMV+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Iterator as Iter import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Multi.Value (atom) -import qualified LLVM.Util.Loop as Loop import qualified LLVM.Core as LLVM -import Foreign.Storable (Storable)-import Foreign.Ptr (Ptr)- import qualified Data.Enum.Storable as Enum import Data.Tagged (Tagged) import Data.Tuple.HT (mapSnd)-import Data.Word (Word8, Word16, Word32, Word64)+import Data.Word (Word8, Word16, Word32, Word64, Word) import Data.Int (Int8, Int16, Int32, Int64)  import qualified Control.Monad.HT as Monad@@ -61,28 +60,29 @@ import Prelude ()  -type Size = Word64+type Size = Word  value :: (C sh, Expr.Value val) => sh -> val sh value = Expr.lift0 . MultiValue.cons  paramWith ::-   (Storable b, MultiMem.C b, Expr.Value val) =>+   (Marshal.MV b) =>    Param.T p b ->    (forall parameters.-    (Storable parameters, MultiMem.C parameters) =>+    (Marshal.MV parameters) =>     (p -> parameters) ->-    (MultiValue.T parameters -> val b) ->+    (forall val. (Expr.Value val) =>+     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)) ->+   (Marshal.MV sh) =>+   f sh -> LLVM.Value (LLVM.Ptr (Marshal.Struct sh)) ->    LLVM.CodeGenFunction r (MultiValue.T sh)-load _ = MultiMem.load+load _ = Memory.load  intersect :: (C sh) => Exp sh -> Exp sh -> Exp sh intersect = Expr.liftM2 intersectCode@@ -108,13 +108,14 @@    We use this for sharing intermediate results.    -}    sizeOffset ::+      (Index sh ~ ix) =>       MultiValue.T sh ->       LLVM.CodeGenFunction r          (LLVM.Value Size,-          MultiValue.T (Index sh) -> LLVM.CodeGenFunction r (LLVM.Value Size))+          MultiValue.T ix -> LLVM.CodeGenFunction r (LLVM.Value Size))    iterator :: (Index sh ~ ix) => MultiValue.T sh -> Iter.T r (MultiValue.T ix)    loop ::-      (Index sh ~ ix, MultiValue.C ix, Loop.Phi state) =>+      (Index sh ~ ix, Tuple.Phi state) =>       (MultiValue.T ix -> state -> LLVM.CodeGenFunction r state) ->       MultiValue.T sh -> state -> LLVM.CodeGenFunction r state    loop f sh = Iter.mapState_ f (iterator sh)@@ -153,12 +154,14 @@  instance ToSize Word8  where toSize (MultiValue.Cons n) = LLVM.ext n instance ToSize Word16 where toSize (MultiValue.Cons n) = LLVM.ext n-instance ToSize Word32 where toSize (MultiValue.Cons n) = LLVM.ext n-instance ToSize Word64 where toSize (MultiValue.Cons n) = return n+instance ToSize Word32 where toSize (MultiValue.Cons n) = LLVM.adapt n+instance ToSize Word64 where toSize (MultiValue.Cons n) = LLVM.adapt n+instance ToSize Word   where toSize (MultiValue.Cons n) = LLVM.adapt n instance ToSize Int8  where toSize (MultiValue.Cons n) = LLVM.zext n instance ToSize Int16 where toSize (MultiValue.Cons n) = LLVM.zext n-instance ToSize Int32 where toSize (MultiValue.Cons n) = LLVM.zext n-instance ToSize Int64 where toSize (MultiValue.Cons n) = LLVM.bitcast n+instance ToSize Int32 where toSize (MultiValue.Cons n) = LLVM.zadapt n+instance ToSize Int64 where toSize (MultiValue.Cons n) = LLVM.zadapt n+instance ToSize Int   where toSize (MultiValue.Cons n) = LLVM.zadapt n   {- |@@ -264,8 +267,8 @@ instance    (ToSize w, MultiValue.Additive w,     LLVM.IsInteger w, SoV.IntegerConstant w, Num w,-    MultiValue.Repr LLVM.Value w ~ LLVM.Value w,-    LLVM.CmpRet w, LLVM.CmpResult w ~ Bool,+    Tuple.ValueOf w ~ LLVM.Value w,+    LLVM.CmpRet w, LLVM.IsPrimitive w,     Enum e, Bounded e) =>       EnumBounded (Enum.T w e) where    enumOffset ix =
src/Data/Array/Knead/Shape/Cubic.hs view
@@ -1,165 +1,97 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} module Data.Array.Knead.Shape.Cubic (-   C(switch),-   switchInt,-   intersect,-   value,    constant,    paramWith,    tunnel,-   offsetCode,-   peek,-   poke,-   computeSize, -   Struct,    T(..),    Z(Z), z,    (:.)((:.)),-   Shape, shape,-   Index, index,+   Shape,+   Index,    cons, (#:.),    head,    tail,    switchR,-   loadMultiValue,-   storeMultiValue,    ) where  import qualified Data.Array.Knead.Shape as Shape import qualified Data.Array.Knead.Shape.Cubic.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 Data.Array.Comfort.Shape as ComfortShape import Data.Array.Comfort.Shape (ZeroBased(ZeroBased)) -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory+import qualified LLVM.DSL.Parameter as Param+ import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Multi.Iterator as IterMV+import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Iterator as Iter import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Control as C-import LLVM.Extra.Multi.Value (Atom, )+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 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+import Foreign.Ptr (castPtr, ) -instance (C ix0, Index.Single i) => C (ix0 :. i) where-   switch _ x = x+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 ((!:)) -newtype SwitchInt f ix i = SwitchInt {runSwitchInt :: f (ix :. i)}+import Control.Monad (liftM2, )+import Control.Applicative (pure, (<$>), ) -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))+import Prelude hiding (min, head, tail, )  -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)+newtype T tag rank = Cons {decons :: FixedLength.T rank Index.Int} +data ShapeTag+data IndexTag -_value :: (C sh, MultiValue.C sh) => sh -> Exp sh-_value = Expr.lift0 . MultiValue.cons+type Shape = T ShapeTag+type Index = T IndexTag  -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) ->+   (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.-    (St.Storable parameters,-     MultiValueMemory.C parameters) =>+    (Marshal.MV parameters) =>     (p -> parameters) ->-    (MultiValue.T parameters -> val (T tag sh)) ->+    (forall val. (Expr.Value val) =>+     MultiValue.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 :: (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+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 MultiValue.cons p   data Z = Z@@ -172,416 +104,195 @@    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))+(#:.) ::+   (Expr.Value val) =>+   val (T tag rank) -> val Index.Int -> val (T tag (Unary.Succ rank)) (#:.) = cons -cons :: (Expr.Value val) => val (T tag sh) -> val i -> val (T tag (sh:.i))+cons ::+   (Expr.Value val) =>+   val (T tag rank) -> val Index.Int -> val (T tag (Unary.Succ rank)) cons =    Expr.lift2 $-      \(MultiValue.Cons t) (MultiValue.Cons h) ->-         MultiValue.Cons (t,h)+      \(MultiValue.Cons t) (MultiValue.Cons h) -> MultiValue.Cons (h!:t) -z :: (Expr.Value val) => val (T tag Z)-z = Expr.lift0 $ MultiValue.Cons ()+z :: (Expr.Value val) => val (T tag Unary.Zero)+z = Expr.lift0 $ MultiValue.Cons FixedLength.end -head :: (Expr.Value val) => val (T tag (sh:.i)) -> val i-head = Expr.lift1 $ \(MultiValue.Cons (_t,h)) -> MultiValue.Cons h+head ::+   (Expr.Value val, Unary.Natural rank) =>+   val (T tag (Unary.Succ rank)) -> val Index.Int+head =+   Expr.lift1 $ \(MultiValue.Cons sh) -> MultiValue.Cons $ FixedLength.head sh -tail :: (Expr.Value val) => val (T tag (sh:.i)) -> val (T tag sh)-tail = Expr.lift1 $ \(MultiValue.Cons (t,_h)) -> MultiValue.Cons t+tail ::+   (Expr.Value val, Unary.Natural rank) =>+   val (T tag (Unary.Succ rank)) -> val (T tag rank)+tail =+   Expr.lift1 $ \(MultiValue.Cons sh) -> MultiValue.Cons $ FixedLength.tail sh  switchR ::+   (Unary.Natural rank) =>    Expr.Value val =>-   (val (T tag sh) -> val i -> a) -> val (T tag (sh :. i)) -> a+   (val (T tag rank) -> val Index.Int -> a) ->+   val (T tag (Unary.Succ rank)) -> 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 ()+rank :: T tag rank -> Proxy rank+rank (Cons _) = Proxy  -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)+instance (tag ~ ShapeTag, rank ~ Unary.Zero) => Shape.Scalar (T tag rank) where+   scalar = Expr.lift0 $ MultiValue.Cons FixedLength.end+   zeroIndex _ = Expr.lift0 $ MultiValue.Cons FixedLength.end  -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+type family AtomRank sh+type instance AtomRank (Atom (T tag rank)) = rank+type instance AtomRank (sh:.s) = Unary.Succ (AtomRank s) -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 family AtomTag sh+type instance AtomTag (Atom (T tag rank)) = tag+type instance AtomTag (sh:.s) = AtomTag sh +type instance MultiValue.PatternTuple (sh:.s) =+   T (AtomTag sh) (Unary.Succ (AtomRank sh)) -type instance MultiValue.PatternTuple (T tag sh) = T tag (PatternTuple sh)+type instance MultiValue.Decomposed f (sh:.s) =+   MultiValue.Decomposed f sh :. f Index.Int -type instance MultiValue.Decomposed f (T tag sh) = Decomposed f tag sh+instance+   (Expr.Decompose sh, Expr.Decompose s,+    MultiValue.Decomposed Exp s ~ Exp Index.Int,+    MultiValue.PatternTuple s ~ Index.Int,+    MultiValue.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 Unwrap sh-type instance Unwrap (T tag sh) = sh+type family Rank sh+type instance Rank (T tag rank) = rank  type family Tag sh-type instance Tag (T tag sh) = tag+type instance Tag (T tag rank) = tag  instance    (Expr.Compose sh,-    Expr.Composed sh ~ T (Tag (Expr.Composed sh)) (Unwrap (Expr.Composed sh)),-    Expr.Compose s) =>+    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))-             (Unwrap (Expr.Composed sh) :. Expr.Composed s)+            T (Tag (Expr.Composed sh)) (Unary.Succ (Rank (Expr.Composed sh)))    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::Shape.Size)+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 = poke (castPtr ptr) . decons-   peek = fmap Cons . peek . castPtr+   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 -type family Repr (f :: * -> *) sh-type instance Repr f Z = ()-type instance Repr f (tail :. head) = (Repr f tail, MultiValue.Repr f head)+toFixedList :: (Unary.Natural n) => [a] -> FixedLength.T n a+toFixedList xs = snd $ Trav.mapAccumL (\(y:ys) () -> (ys,y)) xs (pure ()) -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+   (Unary.Natural rank,+    Dec.Natural (Dec.FromUnary rank),+    Dec.Natural (Dec.FromUnary rank Dec.:*: LLVM.SizeOf Shape.Size)) =>+      Marshal.MV (T tag rank) where -instance (tag ~ ShapeTag, C sh) => ComfortShape.C (T tag sh) where-   size = fromIntegral . size . decons -instance (tag ~ ShapeTag, C sh) => ComfortShape.Indexed (T tag sh) where-   type Index (T tag sh) = Index sh-   indices (Cons ix) = map index $ indices ix-   inBounds (Cons sh) (Cons ix) = inBounds sh ix-   offset (Cons sh) (Cons ix) = offset sh ix+instance (Unary.Natural rank) => Tuple.Value (T tag rank) where+   type ValueOf (T tag rank) = FixedLength.T rank (Tuple.ValueOf Index.Int)+   valueOf = fmap Tuple.valueOf . decons  -newtype Indices sh = Indices {runIndices :: sh -> [sh]}--indices :: (C sh) => sh -> [sh]-indices =-   runIndices $-   switchInt-      (Indices $ \Z -> [Z])-      (Indices $ \(t :. Index.Int h) ->-         liftM2 (:.) (indices t)-            (map Index.Int $ ComfortShape.indices $ ZeroBased h))+instance (Unary.Natural rank) => MultiValue.C (T tag rank) where+   cons = MultiValue.Cons . fmap (\(Index.Int i) -> LLVM.valueOf i) . decons+   undef = constant $ MultiValue.undef+   zero = constant $ MultiValue.zero+   addPhi bb (MultiValue.Cons a) (MultiValue.Cons b) =+      Tuple.addPhiFoldable bb a b+   phi bb (MultiValue.Cons a) =+      fmap MultiValue.Cons . Tuple.phiTraversable bb $ a -newtype InBounds sh = InBounds {runInBounds :: sh -> sh -> Bool}+constant ::+   (Unary.Natural rank) => MultiValue.T Index.Int -> MultiValue.T (T tag rank)+constant (MultiValue.Cons x) = MultiValue.Cons $ pure x -inBounds :: (C sh) => sh -> sh -> Bool-inBounds =-   runInBounds $-   switchInt-      (InBounds $ \Z Z -> True)-      (InBounds $ \(sh :. Index.Int s) (ix :. Index.Int i) ->-         inBounds sh ix && ComfortShape.inBounds (ZeroBased s) i)+instance+   (tag ~ ShapeTag, Unary.Natural rank) =>+      ComfortShape.C (T tag rank) where+   size = Fold.product . fmap (ComfortShape.size . shapeFromInt) . decons -newtype Offset sh = Offset {runOffset :: sh -> sh -> Int}+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)+   offset (Cons sh) (Cons ix) =+      Fold.foldl'+         (\off (s,i) -> off * ComfortShape.size s + fromIntegral i) 0 $+      FixedLength.zipWith (,) (shapeFromInt <$> sh) (indexFromInt <$> ix) -offset :: (C sh) => sh -> sh -> Int-offset =-   runOffset $-   switchInt-      (Offset $ \Z Z -> 0)-      (Offset $ \(sh :. Index.Int s) (ix :. Index.Int i) ->-         offset sh ix * fromIntegral s + fromIntegral i)+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, C sh) => Shape.C (T tag sh) where-   size = computeSize-   intersectCode = Expr.unliftM2 intersect+instance (tag ~ ShapeTag, Unary.Natural rank) => Shape.C (T tag rank) where+   size (MultiValue.Cons sh) = Fold.foldlM A.mul A.one sh+   intersectCode (MultiValue.Cons sh0) (MultiValue.Cons sh1) =+      fmap MultiValue.Cons $ Trav.sequence $ FixedLength.zipWith A.min sh0 sh1    sizeOffset sh =       -- would a joint implementation be more efficient?-      liftM2 (,)-         (computeSize sh)-         (return $ offsetCode sh)+      liftM2 (,) (Shape.size sh) (return $ offsetCode sh)    iterator = iterator    loop = loop  -type family Struct sh-type instance Struct Z = ()-type instance Struct (sh :. Index.Int) = (Shape.Size, 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 OffsetCode r sh =-   OffsetCode {-      runOffsetCode ::-         MultiValue.T (Shape sh) -> MultiValue.T (Index sh) ->-         LLVM.CodeGenFunction r (LLVM.Value Shape.Size)-   }- offsetCode ::-   (C sh) =>-   MultiValue.T (Shape sh) -> MultiValue.T (Index sh) ->-   LLVM.CodeGenFunction r (LLVM.Value Shape.Size)-offsetCode =-   runOffsetCode $-   switchInt-      (OffsetCode $ \_zerosh _zeroix -> return A.zero)-      (OffsetCode $-         switchR $ \sh (MultiValue.Cons s) ->-         switchR $ \ix (MultiValue.Cons i) ->-            A.add i =<< A.mul s =<< offsetCode 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 Shape.Size -> IO sh}--peek :: (C sh) => Ptr Shape.Size -> 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 Shape.Size -> sh -> IO ()}--poke :: (C sh) => Ptr Shape.Size -> 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 Shape.Size))-castPtrValue = LLVM.bitcast--newtype Load r tag sh =-   Load {-      runLoad ::-         LLVM.Value (Ptr Shape.Size) ->-         LLVM.CodeGenFunction r (MultiValue.T (T tag sh))-   }--load ::-   (C sh) =>-   LLVM.Value (Ptr Shape.Size) ->-   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 Shape.Size) ->-         LLVM.CodeGenFunction r ()-   }--store ::-   (C sh) =>-   MultiValue.T (T tag sh) ->-   LLVM.Value (Ptr Shape.Size) ->-   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 -> Shape.Size}--size :: (C sh) => sh -> Shape.Size-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 Shape.Size)-   }--computeSize ::-   (C sh) =>-   MultiValue.T (Shape sh) ->+   (Unary.Natural rank) =>+   MultiValue.T (Shape rank) -> MultiValue.T (Index rank) ->    LLVM.CodeGenFunction r (LLVM.Value Shape.Size)-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))+offsetCode (MultiValue.Cons sh) (MultiValue.Cons ix) =+   Fold.foldlM (\off (s,i) -> A.mul off s >>= A.add i) A.zero $+   FixedLength.zipWith (,) sh ix  -newtype Iterator r sh =+newtype Iterator r rank =    Iterator {       runIterator ::-         MultiValue.T (Shape sh) -> Iter.T r (MultiValue.T (Index sh))+         MultiValue.T (Shape rank) -> Iter.T r (MultiValue.T (Index rank))    }  iterator ::-   (C sh) =>-   MultiValue.T (Shape sh) -> Iter.T r (MultiValue.T (Index sh))+   (Unary.Natural rank) =>+   MultiValue.T (Shape rank) -> Iter.T r (MultiValue.T (Index rank)) iterator =    runIterator $-   switchInt-      (Iterator $ \ _z -> Iter.empty)+   Unary.switchNat+      (Iterator $ \ _z -> Iter.singleton z)       (Iterator $ switchR $ \sh n ->        fmap (\(ix,i) -> ix#:.i) $        Iter.cartesian@@ -590,28 +301,28 @@           Iter.iterate MultiValue.inc MultiValue.zero))  -newtype Loop r state sh =+newtype Loop r state rank =    Loop {       runLoop ::-         (MultiValue.T (Index sh) ->+         (MultiValue.T (Index rank) ->           state ->           LLVM.CodeGenFunction r state) ->-         MultiValue.T (Shape sh) ->+         MultiValue.T (Shape rank) ->          state ->          LLVM.CodeGenFunction r state    }  loop ::-   (C sh, Loop.Phi state) =>-   (MultiValue.T (Index sh) ->+   (Unary.Natural rank, Tuple.Phi state) =>+   (MultiValue.T (Index rank) ->     state ->     LLVM.CodeGenFunction r state) ->-   MultiValue.T (Shape sh) ->+   MultiValue.T (Shape rank) ->    state ->    LLVM.CodeGenFunction r state loop =    runLoop $-   switchInt+   Unary.switchNat       (Loop $ \code _z -> code z)       (Loop $ \code -> switchR $ \sh (MultiValue.Cons n) ->          loop
src/Data/Array/Knead/Shape/Cubic/Int.hs view
@@ -7,19 +7,23 @@ import qualified Data.Array.Knead.Expression as Expr  import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Arithmetic as A -import Data.Word (Word64, )+import qualified LLVM.Core as LLVM +import Data.Word (Word)+ import Prelude hiding (Int, head, tail, )  -newtype Int = Int Word64+newtype Int = Int Word -cons :: (Expr.Value val) => val Word64 -> val Int+cons :: (Expr.Value val) => val Word -> val Int cons = Expr.lift1 $ \(MultiValue.Cons x) -> MultiValue.Cons x -decons :: (Expr.Value val) => val Int -> val Word64+decons :: (Expr.Value val) => val Int -> val Word decons = Expr.lift1 $ \(MultiValue.Cons x) -> MultiValue.Cons x  @@ -30,13 +34,16 @@    switchSingle x = x  +instance Tuple.Value Int where+   type ValueOf Int = LLVM.Value Word+   valueOf (Int x) = LLVM.valueOf x+ instance MultiValue.C Int where-   type Repr f Int = f Word64    cons (Int x) = MultiValue.consPrimitive x    undef = MultiValue.undefPrimitive    zero = MultiValue.zeroPrimitive-   phis = MultiValue.phisPrimitive-   addPhis = MultiValue.addPhisPrimitive+   phi = MultiValue.phiPrimitive+   addPhi = MultiValue.addPhiPrimitive  instance MultiValue.Additive Int where    add = MultiValue.liftM2 A.add@@ -57,3 +64,10 @@  instance MultiValue.Comparison Int where    cmp mode = MultiValue.liftM2 $ A.cmp mode+++instance Marshal.C Int where+   pack (Int i) = i+   unpack = Int++instance Marshal.MV Int where
src/Data/Array/Knead/Shape/Orphan.hs view
@@ -9,11 +9,10 @@          (ZeroBased(ZeroBased), Range(Range), Shifted(Shifted),           Enumeration(Enumeration)) -import qualified LLVM.Extra.Multi.Value.Memory as MultiMem import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Core as LLVM--import qualified Type.Data.Num.Decimal as TypeNum+import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Tuple as Tuple  import qualified Control.Monad.HT as Monad import Control.Applicative ((<$>))@@ -32,13 +31,23 @@ zeroBased :: (Expr.Value val) => val n -> val (ZeroBased n) zeroBased = Expr.lift1 $ \(MultiValue.Cons n) -> MultiValue.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 (MultiValue.C n) => MultiValue.C (ZeroBased n) where-   type Repr f (ZeroBased n) = ZeroBased (MultiValue.Repr f n)    cons (ZeroBased n) = zeroBased (MultiValue.cons n)    undef = zeroBased MultiValue.undef    zero = zeroBased MultiValue.zero-   phis bb = Monad.lift zeroBased . MultiValue.phis bb . zeroBasedSize-   addPhis bb a b = MultiValue.addPhis bb (zeroBasedSize a) (zeroBasedSize b)+   phi bb = Monad.lift zeroBased . MultiValue.phi bb . zeroBasedSize+   addPhi bb a b = MultiValue.addPhi bb (zeroBasedSize a) (zeroBasedSize b)  type instance    MultiValue.Decomposed f (ZeroBased pn) =@@ -62,13 +71,19 @@ instance (Expr.Decompose pn) => Expr.Decompose (ZeroBased pn) where    decompose (ZeroBased p) = ZeroBased . Expr.decompose p . zeroBasedSize -instance (MultiMem.C n) => MultiMem.C (ZeroBased n) where-   type Struct (ZeroBased n) = MultiMem.Struct n-   decompose = fmap zeroBased . MultiMem.decompose-   compose = MultiMem.compose . 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 +instance (Marshal.MV n) => Marshal.MV (ZeroBased n) where ++ singletonRange :: n -> Range n singletonRange n = Range n n @@ -80,20 +95,26 @@ zipRange (MultiValue.Cons from) (MultiValue.Cons to) =    MultiValue.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 (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 =+   phi bb a =       case unzipRange a of          Range a0 a1 ->-            Monad.lift2 zipRange (MultiValue.phis bb a0) (MultiValue.phis bb a1)-   addPhis bb a b =+            Monad.lift2 zipRange (MultiValue.phi bb a0) (MultiValue.phi bb a1)+   addPhi 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+            MultiValue.addPhi bb a0 b0 >>+            MultiValue.addPhi bb a1 b1  type instance    MultiValue.Decomposed f (Range pn) = Range (MultiValue.Decomposed f pn)@@ -113,13 +134,8 @@                (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  - singletonShifted :: n -> Shifted n singletonShifted n = Shifted n n @@ -131,22 +147,29 @@ zipShifted (MultiValue.Cons from) (MultiValue.Cons to) =    MultiValue.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 (MultiValue.C n) => MultiValue.C (Shifted n) where-   type Repr f (Shifted n) = Shifted (MultiValue.Repr f n)    cons (Shifted start len) =       zipShifted (MultiValue.cons start) (MultiValue.cons len)    undef = MultiValue.compose $ singletonShifted MultiValue.undef    zero = MultiValue.compose $ singletonShifted MultiValue.zero-   phis bb a =+   phi bb a =       case unzipShifted a of          Shifted a0 a1 ->             Monad.lift2 zipShifted-               (MultiValue.phis bb a0) (MultiValue.phis bb a1)-   addPhis bb a b =+               (MultiValue.phi bb a0) (MultiValue.phi bb a1)+   addPhi 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+            MultiValue.addPhi bb a0 b0 >>+            MultiValue.addPhi bb a1 b1  type instance    MultiValue.Decomposed f (Shifted pn) =@@ -168,43 +191,18 @@                (MultiValue.decompose pstart start)                (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 (Enum enum, Bounded enum) => Tuple.Value (Enumeration enum) where+   type ValueOf (Enumeration enum) = ()+   valueOf Enumeration = ()  instance (Enum enum, Bounded enum) => MultiValue.C (Enumeration enum) where-   type Repr f (Enumeration enum) = ()    cons = MultiValue.consUnit    undef = MultiValue.undefUnit    zero = MultiValue.zeroUnit-   phis = MultiValue.phisUnit-   addPhis = MultiValue.addPhisUnit+   phi = MultiValue.phiUnit+   addPhi = MultiValue.addPhiUnit  type instance MultiValue.Decomposed f (Enumeration enum) = Enumeration enum type instance MultiValue.PatternTuple (Enumeration enum) = Enumeration enum@@ -224,10 +222,3 @@  instance Expr.Decompose (Enumeration enum) where    decompose Enumeration _ = Enumeration--instance (Enum enum, Bounded enum) => MultiMem.C (Enumeration enum) where-   type Struct (Enumeration enum) = LLVM.Struct ()-   load = MultiMem.loadUnit-   store = MultiMem.storeUnit-   decompose = MultiMem.decomposeUnit-   compose = MultiMem.composeUnit
src/Data/Array/Knead/Simple/Fold.hs view
@@ -9,7 +9,7 @@ {-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Simple.Fold (    T,-   Linear,+   Cubic,    apply,    passAny,    pass,@@ -20,16 +20,19 @@ import qualified Data.Array.Knead.Simple.Private as Core import Data.Array.Knead.Simple.Private (Array(Array), Code, Val, ) -import qualified Data.Array.Knead.Shape.Cubic as Linear-import qualified Data.Array.Knead.Shape.Cubic.Int as IndexInt+import qualified Data.Array.Knead.Shape.Cubic.Int as Index+import qualified Data.Array.Knead.Shape.Cubic as Cubic import qualified Data.Array.Knead.Shape as Shape import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, unExp, ) import Data.Array.Knead.Shape.Cubic ((#:.), (:.)((:.)), ) +import LLVM.DSL.Expression (Exp, unExp)+ import qualified LLVM.Extra.Multi.Value as MultiValue import LLVM.Extra.Multi.Value (atom, ) +import qualified Type.Data.Num.Unary as Unary+ import Prelude hiding (zipWith, zipWith3, zip, zip3, replicate, )  @@ -51,44 +54,45 @@       Array (fsh sh) (\ix -> do sh0 <- unExp sh; reduce sh0 code ix)  -type Linear sh0 sh1 = T (Linear.Shape sh0) (Linear.Shape sh1)+type Cubic rank0 rank1 = T (Cubic.Shape rank0) (Cubic.Shape rank1) -passAny :: Linear sh sh a+passAny :: Cubic rank rank a passAny = Cons id (const id)  pass ::-   Linear sh0 sh1 a ->-   Linear (sh0:.i) (sh1:.i) a+   (Unary.Natural rank0, Unary.Natural rank1, MultiValue.C a) =>+   Cubic rank0 rank1 a ->+   Cubic (Unary.Succ rank0) (Unary.Succ rank1) a pass (Cons fsh reduce) =    Cons-      (Expr.modify (Linear.shape (atom:.atom)) $ \(sh:.s) -> fsh sh :. s)+      (Expr.modify (atom:.atom) $ \(sh:.s) -> fsh sh :. s)       (\sh code ->-       Linear.switchR $ \jx j ->-          reduce (Linear.tail sh) (\kx -> code (kx #:. j)) jx)+       Cubic.switchR $ \jx j ->+          reduce (Cubic.tail sh) (\kx -> code (kx #:. j)) jx)   fold1CodeLinear ::-   (MultiValue.C a) =>+   (Unary.Natural rank, 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)+   Exp Index.Int ->+   (Val (Cubic.Index (Unary.Succ rank)) -> Code r a) ->+   (Val (Cubic.Index rank) -> Code r a) fold1CodeLinear f nc code ix =    Core.fold1Code f-      (Expr.lift1 (MultiValue.compose . Shape.ZeroBased) $ IndexInt.decons nc)-      (\j -> code (ix #:. IndexInt.cons j))+      (Expr.lift1 (MultiValue.compose . Shape.ZeroBased) $ Index.decons nc)+      (\j -> code (ix #:. Index.cons j))  fold ::-   (MultiValue.C a) =>+   (Unary.Natural rank0, Unary.Natural rank1, MultiValue.C a) =>    (Exp a -> Exp a -> Exp a) ->-   Linear sh0 sh1 a ->-   Linear (sh0:.IndexInt.Int) sh1 a+   Cubic rank0 rank1 a ->+   Cubic (Unary.Succ rank0) rank1 a fold f (Cons fsh reduce) =    Cons-      (fsh . Linear.tail)+      (fsh . Cubic.tail)       (\sh code jx ->-          reduce (Linear.tail sh)-             (fold1CodeLinear f (Expr.lift0 (Linear.head sh)) code) jx)+          reduce (Cubic.tail sh)+             (fold1CodeLinear f (Expr.lift0 (Cubic.head sh)) code) jx)   instance Core.Process (T sh0 sh1 a) where
src/Data/Array/Knead/Simple/Physical.hs view
@@ -20,25 +20,26 @@ import qualified Data.Array.Knead.Simple.Private as Sym import qualified Data.Array.Knead.Shape as Shape import qualified Data.Array.Knead.Expression as Expr-import qualified Data.Array.Knead.Code as Code-import Data.Array.Knead.Expression (Exp, unExp, )-import Data.Array.Knead.Code (getElementPtr, compile, )+import Data.Array.Knead.Simple.PhysicalPrivate (MarshalPtr)+import Data.Array.Knead.Code (getElementPtr) +import qualified LLVM.DSL.Execution as Code+import LLVM.DSL.Expression (Exp, unExp)+ import qualified Data.Array.Comfort.Storable.Mutable.Unchecked as MutArray import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Shape as ComfortShape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Storable as Storable+import qualified LLVM.Extra.Marshal as Marshal import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Maybe as Maybe  import qualified LLVM.Core as LLVM -import Foreign.Marshal.Alloc (alloca, )-import Foreign.Storable (Storable, peek, )+import Foreign.Storable (Storable, ) import Foreign.ForeignPtr (withForeignPtr, mallocForeignPtrArray, ) import Foreign.Ptr (FunPtr, Ptr, ) @@ -74,7 +75,7 @@ The symbolic array is only valid inside the enclosed action. -} with ::-   (Shape.C sh, MultiValueMemory.C a) =>+   (Shape.C sh, Storable.C a) =>    (Sym.Array sh a -> IO b) ->    Array sh a -> IO b with f (Array sh fptr) =@@ -83,62 +84,56 @@       Sym.Array          (Shape.value sh)          (\ix ->-            Memory.load =<<-               getElementPtr (Shape.value sh)-                  (LLVM.valueOf (MultiValueMemory.castStructPtr ptr)) ix)+            Storable.loadMultiValue =<<+               getElementPtr (Shape.value sh) (LLVM.valueOf ptr) ix)   type Importer f = FunPtr f -> f  foreign import ccall safe "dynamic" callShaper ::-   Importer (Ptr sh -> IO Shape.Size)+   Importer (LLVM.Ptr sh -> IO Shape.Size)  foreign import ccall safe "dynamic" callRenderer ::-   Importer (Ptr sh -> Ptr am -> IO ())+   Importer (LLVM.Ptr sh -> Ptr a -> IO ())   materialize ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a, MultiValueMemory.Struct a ~ am) =>+   (Shape.C sh, Marshal.MV sh, Storable.C a) =>    String ->    Exp sh ->-   (LLVM.Value (Ptr (MultiValueMemory.Struct sh)) ->-    LLVM.Value (Ptr am) -> LLVM.CodeGenFunction () ()) ->+   (LLVM.Value (MarshalPtr sh) ->+    LLVM.Value (Ptr a) -> LLVM.CodeGenFunction () ()) ->    IO (Array sh a) materialize name esh code =-   alloca $ \shptr -> do+   Marshal.alloca $ \lshptr -> do       (fsh, farr) <--         compile name $+         Code.compile name $          liftA2 (,)             (Code.createFunction callShaper "shape" $ \ptr -> do                sh <- unExp esh-               MultiValueMemory.store sh ptr+               Memory.store sh ptr                Shape.size 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+      withForeignPtr fptr $ farr lshptr+      sh <- Marshal.peek lshptr       return (Array sh fptr)  render ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Storable a, MultiValueMemory.C a) =>+   (Shape.C sh, Marshal.MV sh, Storable.C a) =>    Sym.Array sh a -> IO (Array sh a) render (Sym.Array esh code) =    materialize "render" esh $ \sptr ptr -> do-      let step ix p = do-             flip Memory.store p =<< code ix-             A.advanceArrayElementPtr p+      let step ix p = flip Storable.storeNextMultiValue p =<< code ix       sh <- Shape.load esh sptr       void $ Shape.loop step sh ptr  scanl1 ::-   (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    Shape.C n, Storable n, MultiValueMemory.C n,-    Storable a, MultiValueMemory.C a) =>+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,+    Storable.C a, MultiValue.C a) =>    (Exp a -> Exp a -> Exp a) ->    Sym.Array (sh, n) a -> IO (Array (sh, n) a) scanl1 f (Sym.Array esh code) =@@ -150,17 +145,14 @@                    \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+                ptr1 <- Storable.storeNextMultiValue acc1 ptr0                 return (ptr1, Maybe.just acc1)       void $ Shape.loop step sh ptr  mapAccumLSimple ::-   (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) =>+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,+    MultiValue.C acc, Storable.C x, Storable.C y) =>    (Exp acc -> Exp x -> Exp (acc,y)) ->    Sym.Array sh acc -> Sym.Array (sh, n) x -> IO (Array (sh, n) y) mapAccumLSimple f arrInit arrData =@@ -169,9 +161,8 @@  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) =>+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    Storable.C a) =>    (Exp a -> Exp a -> Exp a) ->    Sym.Array sh1 a ->    Sym.Array sh0 (Maybe (ix1, a)) -> IO (Array sh1 a)@@ -181,9 +172,8 @@  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) =>+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    Storable.C a) =>    (Exp a -> Exp a -> Exp a) ->    Sym.Array sh1 a ->    Sym.Array sh0 (ix1, a) -> IO (Array sh1 a)@@ -193,9 +183,8 @@  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) =>+    Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.MV sh1,+    Storable.C a) =>    (Exp a -> Exp a -> Exp a) ->    Sym.Array sh1 a ->    (Exp ix0 -> Exp ix1) ->
src/Data/Array/Knead/Simple/PhysicalPrivate.hs view
@@ -4,14 +4,14 @@ import qualified Data.Array.Knead.Simple.Private as Sym import qualified Data.Array.Knead.Shape as Shape import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp, unExp) import Data.Array.Knead.Code (getElementPtr) -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory+import LLVM.DSL.Expression (Exp, unExp)+ import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Storable as Storable import qualified LLVM.Extra.Control as C-import qualified LLVM.Extra.Memory as Memory  import qualified LLVM.Core as LLVM @@ -28,47 +28,45 @@   +type MarshalPtr a = LLVM.Ptr (Marshal.Struct a)+ writeArray ::-   (Shape.C sh, Memory.C a) =>+   (Shape.C sh, Shape.Index sh ~ ix, Storable.C a) =>    MultiValue.T sh ->-   (MultiValue.T (Shape.Index sh) -> LLVM.CodeGenFunction r a) ->-   LLVM.Value (Ptr (Memory.Struct a)) ->-   LLVM.CodeGenFunction r (LLVM.Value (Ptr (Memory.Struct a)))+   (MultiValue.T ix -> LLVM.CodeGenFunction r (MultiValue.T a)) ->+   LLVM.Value (Ptr a) ->+   LLVM.CodeGenFunction r (LLVM.Value (Ptr a)) writeArray sh code ptr = do-   let clear ix p = do-         flip Memory.store p =<< code ix-         A.advanceArrayElementPtr p+   let clear ix p = flip Storable.storeNextMultiValue p =<< code ix    Shape.loop clear sh ptr   mapAccumLLoop ::-   (MultiValue.C acc,-    MultiValueMemory.C b, MultiValueMemory.Struct b ~ bm,+   (MultiValue.C acc, Storable.C b,     Shape.C sh, Shape.Index sh ~ ix) =>    (MultiValue.T ix -> LLVM.CodeGenFunction r (MultiValue.T a)) ->    (Exp acc -> Exp a -> Exp (acc, b)) ->    MultiValue.T sh ->-   LLVM.Value (Ptr bm) -> MultiValue.T acc ->-   LLVM.CodeGenFunction r (LLVM.Value (Ptr bm), MultiValue.T acc)+   LLVM.Value (Ptr b) -> MultiValue.T acc ->+   LLVM.CodeGenFunction r (LLVM.Value (Ptr b), MultiValue.T acc) mapAccumLLoop code f n yPtr accInit = do    let step k0 (ptr0, acc0) = do          x <- code k0          (acc1,y) <- MultiValue.unzip <$> Expr.unliftM2 f acc0 x-         Memory.store y ptr0-         ptr1 <- A.advanceArrayElementPtr ptr0+         ptr1 <- Storable.storeNextMultiValue y ptr0          return (ptr1, acc1)    Shape.loop step n (yPtr, accInit)  mapAccumLSimple ::-   (Shape.C sh, MultiValueMemory.C sh,-    Shape.C n, MultiValueMemory.C n,+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,     MultiValue.C acc,-    MultiValueMemory.C x,-    MultiValueMemory.C y) =>+    Storable.C x,+    Storable.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.Value (MarshalPtr (sh,n)) ->+   LLVM.Value (Ptr y) ->    LLVM.CodeGenFunction r () mapAccumLSimple f (Sym.Array _ initCode) (Sym.Array esh code) sptr ptr = do    (sh, n) <- MultiValue.unzip <$> Shape.load esh sptr@@ -78,36 +76,34 @@    void $ Shape.loop step sh ptr  mapAccumLSequence ::-   (Shape.C n, MultiValueMemory.C n,-    MultiValue.C acc, MultiValueMemory.C final,-    MultiValueMemory.C x,-    MultiValueMemory.C y) =>+   (Shape.C n, Marshal.MV n,+    MultiValue.C acc, Storable.C final,+    Storable.C x,+    Storable.C y) =>    (Exp acc -> Exp x -> Exp (acc,y)) ->    (Exp acc -> Exp final) ->    Exp acc -> Sym.Array n x ->-   LLVM.Value (Ptr (MultiValueMemory.Struct final)) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct n)) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct y)) ->+   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 Memory.store accPtr =<< Expr.unliftM1 final accExit+   flip Storable.storeMultiValue accPtr =<< Expr.unliftM1 final accExit  mapAccumL ::-   (Shape.C sh, MultiValueMemory.C sh,-    Shape.C n, MultiValueMemory.C n,-    MultiValue.C acc, MultiValueMemory.C final,-    MultiValueMemory.C x,-    MultiValueMemory.C y) =>+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,+    MultiValue.C acc, Storable.C final,+    Storable.C x,+    Storable.C y) =>    (Exp acc -> Exp x -> Exp (acc,y)) ->    (Exp acc -> Exp final) ->    Sym.Array sh acc -> Sym.Array (sh, n) x ->-   (LLVM.Value (Ptr (MultiValueMemory.Struct sh)),-    LLVM.Value (Ptr (MultiValueMemory.Struct final))) ->-   (LLVM.Value (Ptr (MultiValueMemory.Struct (sh,n))),-    LLVM.Value (Ptr (MultiValueMemory.Struct y))) ->+   (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@@ -116,19 +112,20 @@          accInit <- initCode ix          (ptrStop, accExit) <-             mapAccumLLoop (code . MultiValue.zip ix) f n yPtrStart accInit-         flip Memory.store accPtr0 =<< Expr.unliftM1 final accExit-         accPtr1 <- A.advanceArrayElementPtr accPtr0+         accPtr1 <-+            flip Storable.storeNextMultiValue accPtr0+               =<< Expr.unliftM1 final accExit          return (accPtr1, ptrStop)    void $ Shape.loop step sh (accPtr,yPtr)  foldOuterL ::-   (Shape.C sh, MultiValueMemory.C sh,-    Shape.C n, MultiValueMemory.C n,-    MultiValueMemory.C a) =>+   (Shape.C sh, Marshal.MV sh,+    Shape.C n, Marshal.MV n,+    Storable.C a) =>    (Exp a -> Exp b -> Exp a) ->    Sym.Array sh a -> Sym.Array (n,sh) b ->-   LLVM.Value (Ptr (MultiValueMemory.Struct sh)) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->+   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@@ -137,10 +134,9 @@     let step k ix ptr0 = do          b <- code $ MultiValue.zip k ix-         a0 <- Memory.load ptr0+         a0 <- Storable.loadMultiValue ptr0          a1 <- Expr.unliftM2 f a0 b-         Memory.store a1 ptr0-         A.advanceArrayElementPtr ptr0+         Storable.storeNextMultiValue a1 ptr0    void $ Shape.loop (\k () -> void $ Shape.loop (step k) sh ptr) n ()  {- |@@ -149,13 +145,13 @@ by the fact that you can convert any Index into a Shape. -} mapFilter ::-   (Shape.Sequence n, MultiValueMemory.C n,-    MultiValueMemory.C b) =>+   (Shape.Sequence n, Marshal.MV n,+    Storable.C b) =>    (Exp a -> Exp b) ->    (Exp a -> Exp Bool) ->    Sym.Array n a ->-   LLVM.Value (Ptr (MultiValueMemory.Struct n)) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct b)) ->+   LLVM.Value (MarshalPtr n) ->+   LLVM.Value (Ptr b) ->    LLVM.CodeGenFunction r (MultiValue.T n) mapFilter f p (Sym.Array esh code) sptr ptr = do    n <- Shape.load esh sptr@@ -163,22 +159,20 @@          a <- code ix          MultiValue.Cons c <- Expr.unliftM1 p a          C.ifThen c (dstPtr,dstIx)-            (do-               flip Memory.store dstPtr =<< Expr.unliftM1 f a-               App.lift2 (,)-                  (A.advanceArrayElementPtr dstPtr)-                  (MultiValue.inc dstIx))+            (App.lift2 (,)+               (flip Storable.storeNextMultiValue dstPtr =<< Expr.unliftM1 f a)+               (MultiValue.inc dstIx))    Shape.sequenceShapeFromIndex . snd       =<< Shape.loop step n (ptr, MultiValue.zero)  filterOuter ::-   (Shape.Sequence n, MultiValueMemory.C n,-    Shape.C sh, MultiValueMemory.C sh,-    MultiValueMemory.C a) =>+   (Shape.Sequence n, Marshal.MV n,+    Shape.C sh, Marshal.MV sh,+    Storable.C a) =>    Sym.Array n Bool ->    Sym.Array (n,sh) a ->-   LLVM.Value (Ptr (MultiValueMemory.Struct (n,sh))) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->+   LLVM.Value (MarshalPtr (n,sh)) ->+   LLVM.Value (Ptr a) ->    LLVM.CodeGenFunction r (MultiValue.T (n,sh)) filterOuter (Sym.Array _eish selectCode) (Sym.Array esh code) sptr ptr = do    (n,sh) <- MultiValue.unzip <$> Shape.load esh sptr@@ -197,12 +191,12 @@ scatterMaybe ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,     Shape.C sh1, Shape.Index sh1 ~ ix1,-    MultiValueMemory.C sh1,-    MultiValueMemory.C a) =>+    Marshal.MV sh1,+    Storable.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.Value (MarshalPtr sh1) ->+   LLVM.Value (Ptr a) ->    LLVM.CodeGenFunction r () scatterMaybe accum (Sym.Array esh codeInit) (Sym.Array eish codeMap)       sptr ptr = do@@ -216,21 +210,21 @@             mapSnd MultiValue.unzip . MultiValue.splitMaybe <$> codeMap ix          C.ifThen c () $ do             p <- getElementPtr sh ptr jx-            flip Memory.store p+            flip Storable.storeMultiValue p                =<< Expr.unliftM2 (flip accum) a-               =<< Memory.load p+               =<< Storable.loadMultiValue p    Shape.loop fill ish ()  scatter ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,     Shape.C sh1, Shape.Index sh1 ~ ix1,-    MultiValueMemory.C sh1,-    MultiValueMemory.C a) =>+    Marshal.MV sh1,+    Storable.C a) =>    (Exp a -> Exp a -> Exp a) ->    Sym.Array sh1 a ->    Sym.Array sh0 (Shape.Index sh1, a) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct sh1)) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct 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@@ -240,20 +234,20 @@    let fill ix () = do          (jx, a) <- MultiValue.unzip <$> codeMap ix          p <- getElementPtr sh ptr jx-         flip Memory.store p+         flip Storable.storeMultiValue p             =<< Expr.unliftM2 (flip accum) a-            =<< Memory.load p+            =<< Storable.loadMultiValue p    Shape.loop fill ish ()  addDimension ::-   (Shape.C n, MultiValueMemory.C n, Shape.Index n ~ k,-    Shape.C sh, MultiValueMemory.C sh,-    MultiValueMemory.C b) =>+   (Shape.C n, Marshal.MV n, Shape.Index n ~ k,+    Shape.C sh, Marshal.MV sh,+    Storable.C b) =>    Exp n ->    (Exp k -> Exp a -> Exp b) ->    Sym.Array sh a ->-   LLVM.Value (Ptr (MultiValueMemory.Struct (sh,n))) ->-   LLVM.Value (Ptr (MultiValueMemory.Struct b)) ->+   LLVM.Value (MarshalPtr (sh,n)) ->+   LLVM.Value (Ptr b) ->    LLVM.CodeGenFunction r () addDimension en select (Sym.Array esh code) sptr ptr = do    (sh,n) <- MultiValue.unzip <$> Shape.load (Expr.zip esh en) sptr
src/Data/Array/Knead/Simple/Private.hs view
@@ -4,7 +4,8 @@  import qualified Data.Array.Knead.Shape as Shape import qualified Data.Array.Knead.Expression as Expr-import Data.Array.Knead.Expression (Exp(Exp), )++import LLVM.DSL.Expression (Exp(Exp))  import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Iterator as Iter
src/Data/Array/Knead/Simple/Slice.hs view
@@ -47,7 +47,7 @@ {-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Simple.Slice (    T,-   Linear,+   Cubic,    apply,    passAny,    pass,@@ -69,7 +69,8 @@ import qualified Data.Array.Knead.Simple.ShapeDependent as ShapeDep import qualified Data.Array.Knead.Simple.Private as Core -import qualified Data.Array.Knead.Shape.Cubic as Linear+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 ((#:.), (:.)((:.)), )@@ -78,6 +79,8 @@ import qualified LLVM.Extra.Multi.Value as MultiValue import LLVM.Extra.Multi.Value (atom, ) +import qualified Type.Data.Num.Unary as Unary+ import qualified Prelude as P import Prelude hiding (id, zipWith, zipWith3, zip, zip3, replicate, ) @@ -145,48 +148,51 @@ compose (Cons fshA fixA) (Cons fshB fixB) = Cons (fshB . fshA) (fixA . fixB)  -type Linear sh0 sh1 = T (Linear.Shape sh0) (Linear.Shape sh1)+type Cubic rank0 rank1 = T (Cubic.Shape rank0) (Cubic.Shape rank1)  {- | Like @Any@ in @accelerate@. -}-passAny :: Linear sh sh+passAny :: Cubic rank rank passAny = Cons P.id P.id  {- | Like @All@ in @accelerate@. -} pass ::-   Linear sh0 sh1 ->-   Linear (sh0:.i) (sh1:.i)+   (Unary.Natural rank0, Unary.Natural rank1) =>+   Cubic rank0 rank1 ->+   Cubic (Unary.Succ rank0) (Unary.Succ rank1) 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)+      (Expr.modify (atom:.atom) $ \(sh:.s) -> fsh sh :. s)+      (Expr.modify (atom:.atom) $ \(ix:.i) -> fix ix :. i)  {- | Like @Int@ in @accelerate/slice@. -} pick ::-   Exp i ->-   Linear sh0 sh1 ->-   Linear (sh0:.i) sh1+   (Unary.Natural rank0, Unary.Natural rank1) =>+   Exp Index.Int ->+   Cubic rank0 rank1 ->+   Cubic (Unary.Succ rank0) rank1 pick i (Cons fsh fix) =    Cons-      (fsh . Linear.tail)+      (fsh . Cubic.tail)       (\ix -> fix ix #:. i)  {- | Like @Int@ in @accelerate/replicate@. -} extrude ::-   Exp i ->-   Linear sh0 sh1 ->-   Linear sh0 (sh1:.i)+   (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 . Linear.tail)+      (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.Parameterized.Render as Render+import qualified Data.Array.Knead.Simple.Symbolic as Symb+import qualified Data.Array.Knead.Simple.Slice as Slice+import qualified Data.Array.Knead.Expression as Expr+import qualified Data.Array.Knead.Shape as Shape+import qualified Data.Array.Comfort.Storable as Array+import qualified Data.Array.Comfort.Shape as ComfortShape+import Data.Array.Comfort.Storable (Array)++import qualified LLVM.Extra.Storable as Storable+import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Multi.Value as MultiValue++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, MultiValue.Additive a) =>+   Symb.Array (sh0,sh1) a -> Symb.Array sh0 a+rowSumSymb = Symb.fold1 Expr.add++columnSumSymb ::+   (Shape.C sh0, Shape.C sh1, MultiValue.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.MV sh0, Show sh0,+    Shape.C sh1, Marshal.MV 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) :+   []