packages feed

knead 0.2.0.1 → 0.2.1

raw patch · 12 files changed

+518/−63 lines, 12 filesdep ~llvm-extra

Dependency ranges changed: llvm-extra

Files

knead.cabal view
@@ -1,5 +1,5 @@ Name:             knead-Version:          0.2.0.1+Version:          0.2.1 License:          BSD3 License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -47,7 +47,7 @@ Build-Type:       Simple  Source-Repository this-  Tag:         0.2.0.1+  Tag:         0.2.1   Type:        darcs   Location:    http://hub.darcs.net/thielema/knead/ @@ -57,7 +57,7 @@  Library   Build-Depends:-    llvm-extra >=0.6 && <0.8,+    llvm-extra >=0.7.1 && <0.8,     llvm-tf >=3.1 && <3.2,     storable-tuple >=0.0 && <0.1,     storable-record >=0.0.3 && <0.1,@@ -81,6 +81,7 @@     Data.Array.Knead.Parameterized.Symbolic     Data.Array.Knead.Parameterized.Physical     Data.Array.Knead.Parameterized.Slice+    Data.Array.Knead.Parameterized.Render   Other-Modules:     Data.Array.Knead.Simple.Private     Data.Array.Knead.Parameterized.Private
src/Data/Array/Knead/Expression.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Expression where  import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Monad as LMonad import qualified LLVM.Core as LLVM import LLVM.Extra.Multi.Value (PatternTuple, Decomposed, Atom, atom, )@@ -234,6 +234,14 @@   +instance Compose () where+   type Composed () = ()+   compose = lift0 . MultiValue.cons++instance Decompose () where+   decompose _ _ = ()++ instance (Compose a, Compose b) => Compose (a,b) where    type Composed (a,b) = (Composed a, Composed b)    compose = uncurry zip . Tuple.mapPair (compose, compose)@@ -282,11 +290,69 @@ 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+ fromInteger' :: (MultiValue.IntegerConstant a) => Integer -> Exp a fromInteger' = lift0 . MultiValue.fromInteger'++fromRational' :: (MultiValue.RationalConstant a) => Rational -> Exp a+fromRational' = lift0 . MultiValue.fromRational'+++cmp ::+   (MultiValue.Comparison a) =>+   LLVM.CmpPredicate -> Exp a -> Exp a -> Exp Bool+cmp ord = liftM2 $ MultiValue.cmp ord++infix 4 ==*, /=*, <*, <=*, >*, >=*++(==*), (/=*), (<*), (>=*), (>*), (<=*) ::+   (MultiValue.Comparison a) => Exp a -> Exp a -> Exp Bool+(==*) = cmp LLVM.CmpEQ+(/=*) = cmp LLVM.CmpNE+(<*)  = cmp LLVM.CmpLT+(>=*) = cmp LLVM.CmpGE+(>*)  = cmp LLVM.CmpGT+(<=*) = cmp LLVM.CmpLE+++true, false :: Exp Bool+true = lift0 $ MultiValue.cons True+false = lift0 $ MultiValue.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))   instance
src/Data/Array/Knead/Index/Linear.hs view
@@ -22,7 +22,7 @@     Struct,    T(..),-   Z(Z),+   Z(Z), z,    (:.)((:.)),    Shape, shape,    Index, index,@@ -203,6 +203,11 @@    Expr.Value val =>    (val (T tag sh) -> val i -> a) -> val (T tag (sh :. i)) -> a switchR f ix = f (tail ix) (head ix)+++instance (tag ~ ShapeTag, sh ~ Z) => Shape.Scalar (T tag sh) where+   scalar = Expr.lift0 $ MultiValue.Cons ()+   zeroIndex _ = Expr.lift0 $ MultiValue.Cons ()   type family PatternTuple pattern
src/Data/Array/Knead/Index/Linear/Int.hs view
@@ -43,8 +43,17 @@    sub = MultiValue.liftM2 A.sub    neg = MultiValue.liftM A.neg +instance MultiValue.PseudoRing Int where+   mul = MultiValue.liftM2 A.mul+ instance MultiValue.Real Int where    min = MultiValue.liftM2 A.min    max = MultiValue.liftM2 A.max    abs = MultiValue.liftM A.abs    signum = MultiValue.liftM A.signum++instance MultiValue.IntegerConstant Int where+   fromInteger' = cons . A.fromInteger'++instance MultiValue.Comparison Int where+   cmp mode = MultiValue.liftM2 $ A.cmp mode
src/Data/Array/Knead/Index/Nested/Shape.hs view
@@ -1,7 +1,19 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-}-module Data.Array.Knead.Index.Nested.Shape where+module Data.Array.Knead.Index.Nested.Shape (+   C(..),+   value,+   paramWith,+   load,+   intersect,+   flattenIndex, +   Range(..),+   Shifted(..),++   Scalar(..),+   ) where+ import qualified Data.Array.Knead.Expression as Expr import qualified Data.Array.Knead.Parameter as Param import Data.Array.Knead.Expression (Exp, )@@ -10,6 +22,7 @@ import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Control as C+import LLVM.Extra.Multi.Value (atom) import LLVM.Extra.Monad (liftR2)  import qualified LLVM.Util.Loop as Loop@@ -19,8 +32,10 @@ import Foreign.Ptr (Ptr, )  import Data.Word (Word32, Word64)+import Data.Int (Int32, Int64)  import qualified Control.Monad.HT as Monad+import Control.Applicative ((<$>))   value :: (C sh, Expr.Value val) => sh -> val sh@@ -101,17 +116,30 @@   loopPrimitive ::-   (MultiValue.Repr LLVM.Value i ~ LLVM.Value i,-    Num i, LLVM.IsConst i, LLVM.IsInteger i,-    LLVM.CmpRet i, LLVM.CmpResult i ~ Bool, Loop.Phi state) =>+   (MultiValue.Repr LLVM.Value j ~ LLVM.Value j,+    Num j, LLVM.IsConst j, LLVM.IsInteger j,+    LLVM.CmpRet j, LLVM.CmpResult j ~ Bool,+    MultiValue.Additive i, MultiValue.IntegerConstant i,+    Loop.Phi state) =>    (MultiValue.T i -> state -> LLVM.CodeGenFunction r state) ->-   MultiValue.T i -> state -> LLVM.CodeGenFunction r state+   MultiValue.T j -> state -> LLVM.CodeGenFunction r state loopPrimitive code (MultiValue.Cons n) ptrStart =+   loopStart code n MultiValue.zero ptrStart++loopStart ::+   (Num j, LLVM.IsConst j, LLVM.IsInteger j,+    LLVM.CmpRet j, LLVM.CmpResult j ~ Bool,+    MultiValue.Additive i, MultiValue.IntegerConstant i,+    Loop.Phi state) =>+   (MultiValue.T i -> state -> LLVM.CodeGenFunction r state) ->+   LLVM.Value j ->+   MultiValue.T i -> state -> LLVM.CodeGenFunction r state+loopStart code n start ptrStart =    fmap fst $-   C.fixedLengthLoop n (ptrStart, A.zero) $ \(ptr, k) ->+   C.fixedLengthLoop n (ptrStart, start) $ \(ptr, k) ->       Monad.lift2 (,)-         (code (MultiValue.Cons k) ptr)-         (A.inc k)+         (code k ptr)+         (MultiValue.add k $ MultiValue.fromInteger' 1)  instance C Word32 where    type Index Word32 = Word32@@ -129,6 +157,194 @@    flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) =       Monad.lift2 (,) (LLVM.trunc n) (LLVM.trunc i)    loop = loopPrimitive+++{- |+Array dimensions and indexes cannot be negative,+but computations in indices may temporarily yield negative values+or we want to add negative values to indices.++Maybe we should better have type Index Word64 = Int64?+-}+instance C Int32 where+   type Index Int32 = Int32+   intersectCode = MultiValue.min+   sizeCode (MultiValue.Cons n) = LLVM.bitcast n+   size = fromIntegral+   flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) =+      Monad.lift2 (,) (LLVM.bitcast n) (LLVM.bitcast i)+   loop = loopPrimitive++instance C Int64 where+   type Index Int64 = Int64+   intersectCode = MultiValue.min+   sizeCode (MultiValue.Cons n) = LLVM.trunc n+   size = fromIntegral+   flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) =+      Monad.lift2 (,) (LLVM.trunc n) (LLVM.trunc i)+   loop = loopPrimitive+++{- |+'Range' denotes an inclusive range like+those of the Haskell 98 standard @Array@ type from the @array@ package.+E.g. the shape type @(Range Int32, Range Int64)@+is equivalent to the ix type @(Int32, Int64)@ for @Array@s.+-}+data Range n = Range n n++singletonRange :: n -> Range n+singletonRange n = Range n n+++class+   (MultiValue.Additive n, MultiValue.Real n, MultiValue.IntegerConstant n) =>+      ToSize n where+   toSize :: MultiValue.T n -> LLVM.CodeGenFunction r (LLVM.Value Word32)++instance ToSize Word32 where toSize (MultiValue.Cons n) = LLVM.adapt n+instance ToSize Word64 where toSize (MultiValue.Cons n) = LLVM.adapt n+instance ToSize Int32 where toSize (MultiValue.Cons n) = LLVM.bitcast n+instance ToSize Int64 where toSize (MultiValue.Cons n) = LLVM.trunc n++rangeSize ::+   (ToSize n) =>+   Range (MultiValue.T n) -> LLVM.CodeGenFunction r (LLVM.Value Word32)+rangeSize (Range from to) =+   toSize =<<+   MultiValue.add (MultiValue.fromInteger' 1) =<< MultiValue.sub to from++instance (MultiValue.C n) => MultiValue.C (Range n) where+   type Repr f (Range n) = Range (MultiValue.Repr f n)+   cons (Range from to) =+      MultiValue.compose $ Range (MultiValue.cons from) (MultiValue.cons to)+   undef = MultiValue.compose $ singletonRange MultiValue.undef+   zero = MultiValue.compose $ singletonRange MultiValue.zero+   phis bb a =+      case MultiValue.decompose (singletonRange atom) a of+         Range a0 a1 ->+            fmap MultiValue.compose $+            Monad.lift2 Range (MultiValue.phis bb a0) (MultiValue.phis bb a1)+   addPhis bb a b =+      case (MultiValue.decompose (singletonRange atom) a,+            MultiValue.decompose (singletonRange atom) b) of+         (Range a0 a1, Range b0 b1) ->+            MultiValue.addPhis bb a0 b0 >>+            MultiValue.addPhis bb a1 b1++type instance+   MultiValue.Decomposed f (Range pn) =+      Range (MultiValue.Decomposed f pn)+type instance+   MultiValue.PatternTuple (Range pn) =+      Range (MultiValue.PatternTuple pn)++instance (MultiValue.Compose n) => MultiValue.Compose (Range n) where+   type Composed (Range n) = Range (MultiValue.Composed n)+   compose (Range from to) =+      case (MultiValue.compose from, MultiValue.compose to) of+         (MultiValue.Cons f, MultiValue.Cons t) ->+            MultiValue.Cons (Range f t)++instance (MultiValue.Decompose pn) => MultiValue.Decompose (Range pn) where+   decompose (Range pfrom pto) (MultiValue.Cons (Range from to)) =+      Range+         (MultiValue.decompose pfrom (MultiValue.Cons from))+         (MultiValue.decompose pto (MultiValue.Cons to))++instance (Integral n, ToSize n) => C (Range n) where+   type Index (Range n) = n+   intersectCode =+      MultiValue.modifyF2 (singletonRange atom) (singletonRange atom) $+            \(Range fromN toN) (Range fromM toM) ->+         Monad.lift2 Range (MultiValue.max fromN fromM) (MultiValue.min toN toM)+   sizeCode = rangeSize . MultiValue.decompose (singletonRange atom)+   size (Range from to) = fromIntegral $ to-from+1+   flattenIndexRec rngValue i =+      case MultiValue.decompose (singletonRange atom) rngValue of+         rng@(Range from _to) ->+            Monad.lift2 (,) (rangeSize rng) (toSize =<< MultiValue.sub i from)+   loop code rngValue ptrStart =+      case MultiValue.decompose (singletonRange atom) rngValue of+         rng@(Range from _to) -> do+            {-+            FIXME: rangeSize converts to Word32 which is overly restrictive here.+            -}+            n <- rangeSize rng+            loopStart code n from ptrStart+++{- |+'Shifted' denotes a range defined by the start index and the length.+-}+data Shifted n = Shifted {shiftedOffset, shiftedSize :: n}++singletonShifted :: n -> Shifted n+singletonShifted n = Shifted n n+++instance (MultiValue.C n) => MultiValue.C (Shifted n) where+   type Repr f (Shifted n) = Shifted (MultiValue.Repr f n)+   cons (Shifted offset len) =+      MultiValue.compose $+      Shifted (MultiValue.cons offset) (MultiValue.cons len)+   undef = MultiValue.compose $ singletonShifted MultiValue.undef+   zero = MultiValue.compose $ singletonShifted MultiValue.zero+   phis bb a =+      case MultiValue.decompose (singletonShifted atom) a of+         Shifted a0 a1 ->+            fmap MultiValue.compose $+            Monad.lift2 Shifted (MultiValue.phis bb a0) (MultiValue.phis bb a1)+   addPhis bb a b =+      case (MultiValue.decompose (singletonShifted atom) a,+            MultiValue.decompose (singletonShifted atom) b) of+         (Shifted a0 a1, Shifted b0 b1) ->+            MultiValue.addPhis bb a0 b0 >>+            MultiValue.addPhis bb a1 b1++type instance+   MultiValue.Decomposed f (Shifted pn) =+      Shifted (MultiValue.Decomposed f pn)+type instance+   MultiValue.PatternTuple (Shifted pn) =+      Shifted (MultiValue.PatternTuple pn)++instance (MultiValue.Compose n) => MultiValue.Compose (Shifted n) where+   type Composed (Shifted n) = Shifted (MultiValue.Composed n)+   compose (Shifted offset len) =+      case (MultiValue.compose offset, MultiValue.compose len) of+         (MultiValue.Cons o, MultiValue.Cons l) ->+            MultiValue.Cons (Shifted o l)++instance (MultiValue.Decompose pn) => MultiValue.Decompose (Shifted pn) where+   decompose (Shifted poffset plen) (MultiValue.Cons (Shifted offset len)) =+      Shifted+         (MultiValue.decompose poffset (MultiValue.Cons offset))+         (MultiValue.decompose plen (MultiValue.Cons len))++instance (Integral n, ToSize n) => C (Shifted n) where+   type Index (Shifted n) = n+   intersectCode =+      MultiValue.modifyF2 (singletonShifted atom) (singletonShifted atom) $+            \(Shifted offsetN lenN) (Shifted offsetM lenM) -> do+         offset <- MultiValue.max offsetN offsetM+         endN <- MultiValue.add offsetN lenN+         endM <- MultiValue.add offsetM lenM+         end <- MultiValue.min endN endM+         Shifted offset <$> MultiValue.sub end offset+   sizeCode =+      toSize . shiftedSize . MultiValue.decompose (singletonShifted atom)+   size (Shifted _offset len) = fromIntegral len+   flattenIndexRec shapeValue i =+      case MultiValue.decompose (singletonShifted atom) shapeValue of+         Shifted offset len ->+            Monad.lift2 (,) (toSize len) (toSize =<< MultiValue.sub i offset)+   loop code rngValue ptrStart =+      case MultiValue.decompose (singletonShifted atom) rngValue of+         Shifted from len -> do+            n <- toSize len+            loopStart code n from ptrStart+   instance (C n, C m) => C (n,m) where
src/Data/Array/Knead/Parameterized/Physical.hs view
@@ -82,6 +82,7 @@          case arr param of             Core.Array z code ->                code (Shape.zeroIndex z) >>= flip Memory.store resultPtr+         LLVM.ret ()    return $ \p ->       bracket (create p) (delete . fst) $ \(_ctx, param) ->       with param $ \pptr ->@@ -148,7 +149,8 @@                          flip Memory.store p =<< code ix                          A.advanceArrayElementPtr p                   sh <- Shape.load esh shapePtr-                  void $ Shape.loop step sh bufferPtr)+                  void $ Shape.loop step sh bufferPtr+                  LLVM.ret ())    return $ \p ->       bracket (create p) (delete . fst) $ \(_ctx, param) ->       alloca $ \shptr ->@@ -209,7 +211,8 @@                          flip Memory.store p                             =<< Expr.unliftM2 (flip accum) a                             =<< Memory.load p-                  Shape.loop fill ish ())+                  Shape.loop fill ish ()+            LLVM.ret ())     return $ \p ->       bracket (createBase p) (deleteBase . fst) $ \(_ctxBase, paramBase) ->
src/Data/Array/Knead/Parameterized/Private.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Parameterized.Private where  import qualified Data.Array.Knead.Simple.Symbolic as Core@@ -15,9 +14,12 @@  import Foreign.Storable (Storable, ) +import Control.Applicative (Applicative (pure, (<*>)), )+ import Prelude hiding (id, map, zipWith, replicate, )  +-- in principle we could define Array in terms of Hull and Core.Array data Array p sh a =    forall parameter context.    (Storable parameter, MultiValueMemory.C parameter) =>@@ -39,29 +41,22 @@          (combineDelete deleteA deleteB)  -{--(!) :: (Shape.C sh) => Array p sh a -> Param.T p sh -> Array p z a-(!) arr pix =-   paramArray-      (\ix carr -> Core.fromScalar $ carr Core.! ix)-      (Shape.tunnel pix)-      arr--} (!) ::-   (Shape.C sh, Shape.Index sh ~ ix, MultiValue.C ix,+   (Shape.C sh, Shape.Index sh ~ ix,     Storable ix, MultiValueMemory.C ix,     Shape.Scalar z) =>    Array p sh a -> Param.T p ix -> Array p z a (!) arr pix =-   paramArray+   runHull $+   mapHullWithExp       (\ix carr -> Core.fromScalar $ carr Core.! ix)-      (Param.tunnel MultiValue.cons pix)-      arr+      (expParam pix)+      (arrayHull arr)   fill ::    (Shape.C sh, Storable sh, MultiValueMemory.C sh,-    MultiValue.C a, Storable a, MultiValueMemory.C a) =>+    Storable a, MultiValueMemory.C a) =>    Param.T p sh -> Param.T p a -> Array p sh a fill sh a =    Shape.paramWith sh $ \getSh valueSh ->@@ -127,41 +122,75 @@    (Exp c -> f) ->    Param.T p c -> Array p sh0 a -> Array p sh1 b lift g f c arr =-   paramArray+   runHull $+   mapHullWithExp       (\cexp -> g (f cexp))-      (Param.tunnel MultiValue.cons c)-      arr+      (expParam c)+      (arrayHull arr) -{--Could be generalized to nested indices. -foldSelected1 ::-   (Fold.C sl, MultiValue.C a) =>-   (Exp a -> Exp a -> Exp a) ->-   Param.T p (Linear.Shape sl) ->-   Array p (Linear.Shape (Fold.FullShape sl)) a ->-   Array p (Linear.Shape (Fold.FoldShape sl)) a-foldSelected1 f esl arr =-   paramArray (Core.foldSelected1 f) (Fold.tunnel esl) arr--}+data Hull p a =+   forall parameter context.+   (Storable parameter, MultiValueMemory.C parameter) =>+   Hull {+      hullCore :: MultiValue.T parameter -> a,+      hullCreateContext :: p -> IO (context, parameter),+      hullDeleteContext :: context -> IO ()+   } +instance Functor (Hull p) where+   fmap f (Hull arr create delete) = Hull (f . arr) create delete -paramArray ::-   (Exp sl -> Core.Array shb b -> Core.Array sha a) ->-   Param.Tunnel p sl ->-   Array p shb b -> Array p sha a-paramArray f tunnel (Array arr create delete) =+instance Applicative (Hull p) where+   pure a = Hull (const a) (const $ return ((),())) return+   Hull arrA createA deleteA <*> Hull arrB createB deleteB =+      Hull+         (\p -> case MultiValue.unzip p of (a,b) -> arrA a $ arrB b)+         (combineCreate createA createB)+         (combineDelete deleteA deleteB)++{- |+Equivalent to @liftA2 f (expHull p)@ but saves us an empty context.+-}+mapHullWithExp ::+   (Exp sl -> a -> b) ->+   Param.Tunnel p sl -> Hull p a -> Hull p b+mapHullWithExp f tunnel (Hull arr create delete) =    case tunnel of       Param.Tunnel getSl valueSl ->-         Array+         Hull             (\p ->                case MultiValue.unzip p of-                  (arrp, sl) ->-                     f (Expr.lift0 $ valueSl sl) $ arr arrp)+                  (arrp, sl) -> f (Expr.lift0 $ valueSl sl) $ arr arrp)             (\p -> do                (ctx, param) <- create p                return (ctx, (param, getSl p)))             delete++expHull :: Param.Tunnel p sl -> Hull p (Exp sl)+expHull tunnel =+   case tunnel of+      Param.Tunnel getSl valueSl ->+         Hull+            (Expr.lift0 . valueSl)+            (\p -> return ((), getSl p))+            return++arrayHull :: Array p sh a -> Hull p (Core.Array sh a)+arrayHull (Array arr create delete) = Hull arr create delete++runHull :: Hull p (Core.Array sh a) -> Array p sh a+runHull (Hull arr create delete) = Array arr create delete++extendHull :: (q -> p) -> Hull p a -> Hull q a+extendHull f (Hull arr create delete) = Hull arr (create . f) delete++++expParam ::+   (Storable a, MultiValueMemory.C a) => Param.T p a -> Param.Tunnel p a+expParam = Param.tunnel MultiValue.cons+   createPlain :: (Monad m) => (p -> pl) -> p -> m ((), pl)
+ src/Data/Array/Knead/Parameterized/Render.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TypeFamilies #-}+{- |+Simplify running the @render@ function by handling passing of parameters.+-}+module Data.Array.Knead.Parameterized.Render (run) where++import qualified Data.Array.Knead.Parameterized.Physical as PhysP+import qualified Data.Array.Knead.Parameterized.Private as Sym+import qualified Data.Array.Knead.Simple.Physical as Phys+import qualified Data.Array.Knead.Simple.Private as Core+import qualified Data.Array.Knead.Parameter as Param+import qualified Data.Array.Knead.Index.Nested.Shape as Shape+import Data.Array.Knead.Expression (Exp, )++import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory++import Foreign.Storable (Storable, )++import Control.Arrow (arr, )+import Control.Applicative (liftA2, liftA3, pure, (<*>), )++import Data.Tuple.HT (fst3, snd3, thd3, )+++class C f where+   type Plain f+   build :: Sym.Hull p f -> IO (p -> Plain f)++instance+   (MultiValueMemory.C sh, Storable sh, Shape.C sh,+    MultiValueMemory.C a, Storable a) =>+      C (Core.Array sh a) where+   type Plain (Core.Array sh a) = IO (Phys.Array sh a)+   build = PhysP.render . Sym.runHull++singleton :: Exp a -> Core.Array () a+singleton = Core.fromScalar++instance (MultiValueMemory.C a, Storable a) => C (Exp a) where+   type Plain (Exp a) = IO a+   build = PhysP.the . Sym.runHull . fmap singleton++instance (Argument arg, C func) => C (arg -> func) where+   type Plain (arg -> func) = PlainArg arg -> Plain func+   build f = fmap curry $ build $ Sym.extendHull fst f <*> buildArg (arr snd)+++class Argument arg where+   type PlainArg arg+   buildArg :: Param.T p (PlainArg arg) -> Sym.Hull p arg++instance+   (MultiValueMemory.C sh, Storable sh, Shape.C sh, MultiValueMemory.C a) =>+      Argument (Core.Array sh a) where+   type PlainArg (Core.Array sh a) = Phys.Array sh a+   buildArg = Sym.arrayHull . PhysP.feed++instance (MultiValueMemory.C a, Storable a) => Argument (Exp a) where+   type PlainArg (Exp a) = a+   buildArg = Sym.expHull . Sym.expParam++instance (Argument a, Argument b) => Argument (a,b) where+   type PlainArg (a,b) = (PlainArg a, PlainArg b)+   buildArg p = liftA2 (,) (buildArg $ fmap fst p) (buildArg $ fmap snd p)++instance (Argument a, Argument b, Argument c) => Argument (a,b,c) where+   type PlainArg (a,b,c) = (PlainArg a, PlainArg b, PlainArg c)+   buildArg p =+      liftA3 (,,)+         (buildArg $ fmap fst3 p) (buildArg $ fmap snd3 p) (buildArg $ fmap thd3 p)+++run :: (C f) => f -> IO (Plain f)+run f = fmap ($()) $ build $ pure f++++_example ::+   (Storable x, MultiValueMemory.C x,+    Shape.C sha, Storable sha, MultiValueMemory.C sha, MultiValueMemory.C a,+    Shape.C shb, Storable shb, MultiValueMemory.C shb, MultiValueMemory.C b,+    Shape.C shc, Storable shc, MultiValueMemory.C shc, MultiValueMemory.C c,+    Storable c) =>+   (Exp x -> Core.Array sha a -> Core.Array shb b -> Core.Array shc c) ->+   IO (x -> Phys.Array sha a -> Phys.Array shb b -> IO (Phys.Array shc c))+_example f =+   fmap (\g -> curry $ curry g) $+   PhysP.render $+   Sym.runHull $+   pure f+      <*> Sym.expHull (Sym.expParam $ arr (fst.fst))+      <*> Sym.arrayHull (PhysP.feed $ arr (snd.fst))+      <*> Sym.arrayHull (PhysP.feed $ arr snd)
src/Data/Array/Knead/Parameterized/Symbolic.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Parameterized.Symbolic (    Array,    Exp,    Sym.extendParameter,+   withExp,+   withExp2,+   withExp3,    (Sym.!),    Sym.fill,    gather,@@ -30,9 +32,11 @@  import Foreign.Storable (Storable, ) -import Prelude (uncurry, ($), )+import Control.Applicative ((<*>), ) +import Prelude (uncurry, ($), (.), ) + {- fromScalar ::    (Storable a, MultiValueMemory.C a, MultiValue.C a) =>@@ -52,15 +56,39 @@    Array p sh1 a backpermute sh1 f = gather (Core.map f (Sym.id sh1)) -{--_backpermute sh1 f =-   paramArray (flip Core.backpermute f) (Shape.tunnel sh1)--} - zipWith ::    (Shape.C sh, MultiValueMemory.C d, Storable d) =>    (Exp d -> Exp a -> Exp b -> Exp c) ->    Param.T p d -> Array p sh a -> Array p sh b -> Array p sh c zipWith f d a b =    Sym.map (\di ab -> uncurry (f di) $ Expr.unzip ab) d $ Core.zip a b+++withExp ::+   (Storable x, MultiValueMemory.C x) =>+   (Exp x -> Core.Array shb b -> Core.Array sha a) ->+   Param.T p x -> Array p shb b -> Array p sha a+withExp f x =+   Sym.runHull . Sym.mapHullWithExp f (Sym.expParam x) . Sym.arrayHull++withExp2 ::+   (Storable x, MultiValueMemory.C x) =>+   (Exp x -> Core.Array sha a -> Core.Array shb b -> Core.Array shc c) ->+   Param.T p x -> Array p sha a -> Array p shb b -> Array p shc c+withExp2 f x a b =+   Sym.runHull $+   Sym.mapHullWithExp f (Sym.expParam x) (Sym.arrayHull a)+     <*> Sym.arrayHull b++withExp3 ::+   (Storable x, MultiValueMemory.C x) =>+   (Exp x -> Core.Array sha a ->+    Core.Array shb b -> Core.Array shc c -> Core.Array shd d) ->+   Param.T p x -> Array p sha a ->+   Array p shb b -> Array p shc c -> Array p shd d+withExp3 f x a b c =+   Sym.runHull $+   Sym.mapHullWithExp f (Sym.expParam x) (Sym.arrayHull a)+     <*> Sym.arrayHull b+     <*> Sym.arrayHull c
src/Data/Array/Knead/Simple/Physical.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ForeignFunctionInterface #-} module Data.Array.Knead.Simple.Physical (    Array(Array, shape, buffer), -- data constructor intended for PhysicalParameterized+   toList,    fromList,    vectorFromList,    with,@@ -29,7 +29,7 @@  import qualified LLVM.Core as LLVM -import Foreign.Marshal.Array (pokeArray, )+import Foreign.Marshal.Array (pokeArray, peekArray, ) import Foreign.Marshal.Alloc (alloca, ) import Foreign.Storable (Storable, peek, ) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray, )@@ -49,6 +49,12 @@    }  +toList ::+   (Shape.C sh, Storable a) =>+   Array sh a -> IO [a]+toList (Array sh fptr) =+   withForeignPtr fptr $ peekArray (Shape.size sh)+ fromList ::    (Shape.C sh, Storable a) =>    sh -> [a] -> IO (Array sh a)@@ -116,7 +122,8 @@                sh <- unExp esh                MultiValueMemory.store sh ptr                Shape.sizeCode sh >>= LLVM.ret)-            (Code.createFunction callRenderer "fill" code)+            (Code.createFunction callRenderer "fill"+               (\paramPtr arrayPtr -> code paramPtr arrayPtr >> LLVM.ret ()))       let lshptr = MultiValueMemory.castStructPtr shptr       n <- fsh lshptr       fptr <- mallocForeignPtrArray (fromIntegral n)
src/Data/Array/Knead/Simple/Private.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Simple.Private where  import qualified Data.Array.Knead.Index.Nested.Shape as Shape
src/Data/Array/Knead/Simple/Symbolic.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Simple.Symbolic (    Core.Array,    Core.C(..),