packages feed

knead 0.2.2 → 0.2.3

raw patch · 12 files changed

+754/−187 lines, 12 filesdep +tfpdep ~llvm-extra

Dependencies added: tfp

Dependency ranges changed: llvm-extra

Files

knead.cabal view
@@ -1,5 +1,5 @@ Name:             knead-Version:          0.2.2+Version:          0.2.3 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.2+  Tag:         0.2.3   Type:        darcs   Location:    http://hub.darcs.net/thielema/knead/ @@ -57,8 +57,9 @@  Library   Build-Depends:-    llvm-extra >=0.7.1 && <0.8,+    llvm-extra >=0.7.3 && <0.8,     llvm-tf >=3.1 && <3.2,+    tfp >=1.0 && <1.1,     storable-tuple >=0.0 && <0.1,     storable-record >=0.0.3 && <0.1,     transformers >=0.3 && <0.6,@@ -84,5 +85,7 @@     Data.Array.Knead.Parameterized.Render   Other-Modules:     Data.Array.Knead.Simple.Private+    Data.Array.Knead.Simple.PhysicalPrivate     Data.Array.Knead.Parameterized.Private+    Data.Array.Knead.Parameterized.PhysicalHull     Data.Array.Knead.Code
src/Data/Array/Knead/Expression.hs view
@@ -16,7 +16,8 @@ import Data.Complex (Complex((:+)))  import Prelude-   hiding (fst, snd, min, max, zip, unzip, zip3, unzip3, curry, uncurry, pi)+   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)}@@ -361,6 +362,12 @@ 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' @@ -412,6 +419,31 @@    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)   instance
src/Data/Array/Knead/Index/Nested/Shape.hs view
@@ -18,7 +18,7 @@ import qualified Data.Array.Knead.Parameter as Param import Data.Array.Knead.Expression (Exp, ) -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory+import qualified LLVM.Extra.Multi.Value.Memory as MultiMem import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Control as C@@ -28,12 +28,15 @@ import qualified LLVM.Util.Loop as Loop import qualified LLVM.Core as LLVM -import Foreign.Storable (Storable, )-import Foreign.Ptr (Ptr, )+import qualified Type.Data.Num.Decimal as TypeNum -import Data.Word (Word32, Word64)-import Data.Int (Int32, Int64)+import Foreign.Storable+         (Storable, sizeOf, alignment, poke, peek, pokeElemOff, peekElemOff)+import Foreign.Ptr (Ptr, castPtr) +import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int8, Int16, Int32, Int64)+ import qualified Control.Monad.HT as Monad import Control.Applicative ((<$>)) @@ -42,11 +45,10 @@ value = Expr.lift0 . MultiValue.cons  paramWith ::-   (Storable b, MultiValueMemory.C b, Expr.Value val) =>+   (Storable b, MultiMem.C b, Expr.Value val) =>    Param.T p b ->    (forall parameters.-    (Storable parameters,-     MultiValueMemory.C parameters) =>+    (Storable parameters, MultiMem.C parameters) =>     (p -> parameters) ->     (MultiValue.T parameters -> val b) ->     a) ->@@ -55,10 +57,10 @@    Param.withMulti p (\get val -> f get (Expr.lift0 . val))  load ::-   (MultiValueMemory.C sh) =>-   f sh -> LLVM.Value (Ptr (MultiValueMemory.Struct sh)) ->+   (MultiMem.C sh) =>+   f sh -> LLVM.Value (Ptr (MultiMem.Struct sh)) ->    LLVM.CodeGenFunction r (MultiValue.T sh)-load _ = MultiValueMemory.load+load _ = MultiMem.load  intersect :: (C sh) => Exp sh -> Exp sh -> Exp sh intersect = Expr.liftM2 intersectCode@@ -137,9 +139,7 @@ loopStart code n start ptrStart =    fmap fst $    C.fixedLengthLoop n (ptrStart, start) $ \(ptr, k) ->-      Monad.lift2 (,)-         (code k ptr)-         (MultiValue.add k $ MultiValue.fromInteger' 1)+      Monad.lift2 (,) (code k ptr) (MultiValue.inc k)  instance C Word32 where    type Index Word32 = Word32@@ -166,6 +166,30 @@  Maybe we should better have type Index Word64 = Int64? -}+unsigned8 :: LLVM.Value Int8 -> LLVM.CodeGenFunction r (LLVM.Value Word8)+unsigned8 = LLVM.bitcast++instance C Int8 where+   type Index Int8 = Int8+   intersectCode = MultiValue.min+   sizeCode (MultiValue.Cons n) = LLVM.ext =<< unsigned8 n+   size = fromIntegral+   flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) =+      Monad.lift2 (,) (LLVM.ext =<< unsigned8 n) (LLVM.ext =<< unsigned8 i)+   loop = loopPrimitive++unsigned16 :: LLVM.Value Int16 -> LLVM.CodeGenFunction r (LLVM.Value Word16)+unsigned16 = LLVM.bitcast++instance C Int16 where+   type Index Int16 = Int16+   intersectCode = MultiValue.min+   sizeCode (MultiValue.Cons n) = LLVM.ext =<< unsigned16 n+   size = fromIntegral+   flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) =+      Monad.lift2 (,) (LLVM.ext =<< unsigned16 n) (LLVM.ext =<< unsigned16 i)+   loop = loopPrimitive+ instance C Int32 where    type Index Int32 = Int32    intersectCode = MultiValue.min@@ -197,6 +221,26 @@ singletonRange n = Range n n  +{-# INLINE castToElemPtr #-}+castToElemPtr :: Ptr (f a) -> Ptr a+castToElemPtr = castPtr++-- cf. sample-frame:Stereo+instance Storable n => Storable (Range n) where+   {-# INLINE sizeOf #-}+   {-# INLINE alignment #-}+   {-# INLINE peek #-}+   {-# INLINE poke #-}+   sizeOf ~(Range l r) = sizeOf l + mod (- sizeOf l) (alignment r) + sizeOf r+   alignment ~(Range l _) = alignment l+   poke p (Range l r) =+      let q = castToElemPtr p+      in  poke q l >> pokeElemOff q 1 r+   peek p =+      let q = castToElemPtr p+      in  Monad.lift2 Range (peek q) (peekElemOff q 1)++ class    (MultiValue.Additive n, MultiValue.Real n, MultiValue.IntegerConstant n) =>       ToSize n where@@ -211,23 +255,27 @@    (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+   toSize =<< MultiValue.inc =<< MultiValue.sub to from +unzipRange :: MultiValue.T (Range n) -> Range (MultiValue.T n)+unzipRange (MultiValue.Cons (Range from to)) =+   Range (MultiValue.Cons from) (MultiValue.Cons to)++zipRange :: MultiValue.T n -> MultiValue.T n -> MultiValue.T (Range n)+zipRange (MultiValue.Cons from) (MultiValue.Cons to) =+   MultiValue.Cons (Range from to)+ instance (MultiValue.C n) => MultiValue.C (Range n) where    type Repr f (Range n) = Range (MultiValue.Repr f n)-   cons (Range from to) =-      MultiValue.compose $ Range (MultiValue.cons from) (MultiValue.cons to)+   cons (Range from to) = zipRange (MultiValue.cons from) (MultiValue.cons to)    undef = MultiValue.compose $ singletonRange MultiValue.undef    zero = MultiValue.compose $ singletonRange MultiValue.zero    phis bb a =-      case MultiValue.decompose (singletonRange atom) a of+      case unzipRange a of          Range a0 a1 ->-            fmap MultiValue.compose $-            Monad.lift2 Range (MultiValue.phis bb a0) (MultiValue.phis bb a1)+            Monad.lift2 zipRange (MultiValue.phis bb a0) (MultiValue.phis bb a1)    addPhis bb a b =-      case (MultiValue.decompose (singletonRange atom) a,-            MultiValue.decompose (singletonRange atom) b) of+      case (unzipRange a, unzipRange b) of          (Range a0 a1, Range b0 b1) ->             MultiValue.addPhis bb a0 b0 >>             MultiValue.addPhis bb a1 b1@@ -242,30 +290,35 @@ 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)+      zipRange (MultiValue.compose from) (MultiValue.compose to)  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))+   decompose (Range pfrom pto) rng =+      case unzipRange rng of+         Range from to ->+            Range+               (MultiValue.decompose pfrom from)+               (MultiValue.decompose pto to) +instance (MultiMem.C n) => MultiMem.C (Range n) where+   type Struct (Range n) = PairStruct n+   decompose = fmap (uncurry zipRange) . decomposeGen+   compose x = case unzipRange x of Range n m -> composeGen n m+ instance (Integral n, ToSize n) => C (Range n) where    type Index (Range n) = n    intersectCode =       MultiValue.modifyF2 (singletonRange atom) (singletonRange atom) $             \(Range fromN toN) (Range fromM toM) ->          Monad.lift2 Range (MultiValue.max fromN fromM) (MultiValue.min toN toM)-   sizeCode = rangeSize . MultiValue.decompose (singletonRange atom)+   sizeCode = rangeSize . unzipRange    size (Range from to) = fromIntegral $ to-from+1    flattenIndexRec rngValue i =-      case MultiValue.decompose (singletonRange atom) rngValue of+      case unzipRange 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+      case unzipRange rngValue of          rng@(Range from _to) -> do             {-             FIXME: rangeSize converts to Word32 which is overly restrictive here.@@ -283,21 +336,43 @@ singletonShifted n = Shifted n n  +-- cf. sample-frame:Stereo+instance Storable n => Storable (Shifted n) where+   {-# INLINE sizeOf #-}+   {-# INLINE alignment #-}+   {-# INLINE peek #-}+   {-# INLINE poke #-}+   sizeOf ~(Shifted l n) = sizeOf l + mod (- sizeOf l) (alignment n) + sizeOf n+   alignment ~(Shifted l _) = alignment l+   poke p (Shifted l n) =+      let q = castToElemPtr p+      in  poke q l >> pokeElemOff q 1 n+   peek p =+      let q = castToElemPtr p+      in  Monad.lift2 Shifted (peek q) (peekElemOff q 1)+++unzipShifted :: MultiValue.T (Shifted n) -> Shifted (MultiValue.T n)+unzipShifted (MultiValue.Cons (Shifted from to)) =+   Shifted (MultiValue.Cons from) (MultiValue.Cons to)++zipShifted :: MultiValue.T n -> MultiValue.T n -> MultiValue.T (Shifted n)+zipShifted (MultiValue.Cons from) (MultiValue.Cons to) =+   MultiValue.Cons (Shifted from to)+ instance (MultiValue.C n) => MultiValue.C (Shifted n) where    type Repr f (Shifted n) = Shifted (MultiValue.Repr f n)    cons (Shifted offset len) =-      MultiValue.compose $-      Shifted (MultiValue.cons offset) (MultiValue.cons len)+      zipShifted (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+      case unzipShifted a of          Shifted a0 a1 ->-            fmap MultiValue.compose $-            Monad.lift2 Shifted (MultiValue.phis bb a0) (MultiValue.phis bb a1)+            Monad.lift2 zipShifted+               (MultiValue.phis bb a0) (MultiValue.phis bb a1)    addPhis bb a b =-      case (MultiValue.decompose (singletonShifted atom) a,-            MultiValue.decompose (singletonShifted atom) b) of+      case (unzipShifted a, unzipShifted b) of          (Shifted a0 a1, Shifted b0 b1) ->             MultiValue.addPhis bb a0 b0 >>             MultiValue.addPhis bb a1 b1@@ -312,16 +387,43 @@ 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)+      zipShifted (MultiValue.compose offset) (MultiValue.compose len)  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))+   decompose (Shifted poffset plen) rng =+      case unzipShifted rng of+         Shifted offset len ->+            Shifted+               (MultiValue.decompose poffset offset)+               (MultiValue.decompose plen len) +instance (MultiMem.C n) => MultiMem.C (Shifted n) where+   type Struct (Shifted n) = PairStruct n+   decompose = fmap (uncurry zipShifted) . decomposeGen+   compose x = case unzipShifted x of Shifted n m -> composeGen n m++type PairStruct n = LLVM.Struct (MultiMem.Struct n, (MultiMem.Struct n, ()))++decomposeGen ::+   (MultiMem.C n) =>+   LLVM.Value (PairStruct n) ->+   LLVM.CodeGenFunction r (MultiValue.T n, MultiValue.T n)+decomposeGen nm =+   Monad.lift2 (,)+      (MultiMem.decompose =<< LLVM.extractvalue nm TypeNum.d0)+      (MultiMem.decompose =<< LLVM.extractvalue nm TypeNum.d1)++composeGen ::+   (MultiMem.C n) =>+   MultiValue.T n -> MultiValue.T n ->+   LLVM.CodeGenFunction r (LLVM.Value (PairStruct n))+composeGen n m = do+   sn <- MultiMem.compose n+   sm <- MultiMem.compose m+   rn <- LLVM.insertvalue (LLVM.value LLVM.undef) sn TypeNum.d0+   LLVM.insertvalue rn sm TypeNum.d1++ instance (Integral n, ToSize n) => C (Shifted n) where    type Index (Shifted n) = n    intersectCode =@@ -332,15 +434,14 @@          endM <- MultiValue.add offsetM lenM          end <- MultiValue.min endN endM          Shifted offset <$> MultiValue.sub end offset-   sizeCode =-      toSize . shiftedSize . MultiValue.decompose (singletonShifted atom)+   sizeCode = toSize . shiftedSize . unzipShifted    size (Shifted _offset len) = fromIntegral len    flattenIndexRec shapeValue i =-      case MultiValue.decompose (singletonShifted atom) shapeValue of+      case unzipShifted 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+      case unzipShifted rngValue of          Shifted from len -> do             n <- toSize len             loopStart code n from ptrStart
src/Data/Array/Knead/Parameterized/Physical.hs view
@@ -8,10 +8,14 @@    the,    render,    renderShape,+   mapAccumL,+   foldOuterL,    scatter,+   scatterMaybe,    permute,    ) where +import qualified Data.Array.Knead.Parameterized.PhysicalHull as PhysHull import qualified Data.Array.Knead.Parameterized.Private as Sym import qualified Data.Array.Knead.Simple.Physical as Phys import qualified Data.Array.Knead.Simple.Private as Core@@ -24,7 +28,6 @@  import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory import qualified LLVM.Extra.Multi.Value as MultiValue-import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Memory as Memory  import qualified LLVM.Core as LLVM@@ -32,18 +35,16 @@ import Foreign.Marshal.Utils (with, ) import Foreign.Marshal.Alloc (alloca, ) import Foreign.Storable (Storable, peek, )-import Foreign.ForeignPtr (withForeignPtr, mallocForeignPtrArray, touchForeignPtr, )+import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, ) import Foreign.Ptr (FunPtr, Ptr, )  import Control.Exception (bracket, )-import Control.Monad.HT (void, (<=<), )+import Control.Monad.HT ((<=<), ) import Control.Applicative (liftA2, ) import Data.Tuple.HT (mapFst, ) import Data.Word (Word32, ) -import Prelude hiding (scanl1, ) - feed ::    (Shape.C sh, Storable sh, MultiValueMemory.C sh,     MultiValueMemory.C a) =>@@ -94,10 +95,7 @@ foreign import ccall safe "dynamic" callShaper ::    Importer (Ptr param -> Ptr shape -> IO Word32) -foreign import ccall safe "dynamic" callRenderer ::-   Importer (Ptr param -> Ptr shape -> Ptr am -> IO ()) - renderShape ::    (Shape.C sh, Storable sh, MultiValueMemory.C sh,     Storable a, MultiValueMemory.C a) =>@@ -128,46 +126,38 @@    (Shape.C sh, Storable sh, MultiValueMemory.C sh,     Storable a, MultiValueMemory.C a) =>    Sym.Array p sh a -> IO (p -> IO (Phys.Array sh a))-render (Sym.Array arr create delete) = do-   (fsh, farr) <--      compile "render" $-      liftA2 (,)-         (Code.createFunction callShaper "shape" $-          \paramPtr resultPtr -> do-            param <- Memory.load paramPtr-            case arr param of-               Core.Array esh _code -> do-                  sh <- unExp esh-                  MultiValueMemory.store sh resultPtr-                  Shape.sizeCode sh >>= LLVM.ret)-         (Code.createFunction callRenderer "fill" $-          \paramPtr shapePtr bufferPtr -> do-            param <- Memory.load paramPtr-            case arr param of-               Core.Array esh code -> do-                  let step ix p = do-                         flip Memory.store p =<< code ix-                         A.advanceArrayElementPtr p-                  sh <- Shape.load esh shapePtr-                  void $ Shape.loop step sh bufferPtr-                  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-         fptr <- mallocForeignPtrArray (fromIntegral n)-         withForeignPtr fptr $-            farr lpptr lshptr . MultiValueMemory.castStructPtr-         sh <- peek shptr-         return (Phys.Array sh fptr)+render = PhysHull.render . Sym.arrayHull  +mapAccumL ::+   (Shape.C sh, Storable sh, MultiValueMemory.C sh,+    Shape.C n, Storable n, MultiValueMemory.C n,+    MultiValue.C acc,+    Storable a, MultiValueMemory.C a,+    Storable b, MultiValueMemory.C b) =>+   (Exp acc -> Exp a -> Exp (acc,b)) ->+   Sym.Array p sh acc ->+   Sym.Array p (sh, n) a ->+   IO (p -> IO (Phys.Array (sh,n) b))+mapAccumL f arrInit arrMap =+   PhysHull.mapAccumL $+      liftA2 (PhysHull.MapAccumL f)+         (Sym.arrayHull arrInit)+         (Sym.arrayHull arrMap) -foreign import ccall safe "dynamic" callScatterer ::-   Importer (Ptr paramBase -> Ptr paramMap -> Ptr shape -> Ptr am -> IO ())+foldOuterL ::+   (Shape.C sh, Storable sh, MultiValueMemory.C sh,+    Shape.C n, Storable n, MultiValueMemory.C n,+    Storable a, MultiValueMemory.C a) =>+   (Exp a -> Exp b -> Exp a) ->+   Sym.Array p sh a ->+   Sym.Array p (n,sh) b ->+   IO (p -> IO (Phys.Array sh a))+foldOuterL f arrInit arrMap =+   PhysHull.foldOuterL $+      liftA2 (PhysHull.FoldOuterL f)+         (Sym.arrayHull arrInit)+         (Sym.arrayHull arrMap)  scatter ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,@@ -177,59 +167,25 @@    (Exp a -> Exp a -> Exp a) ->    Sym.Array p sh1 a ->    Sym.Array p sh0 (ix1, a) -> IO (p -> IO (Phys.Array sh1 a))-scatter accum-      (Sym.Array arrBase createBase deleteBase)-      (Sym.Array arrMap createMap deleteMap) = do--   (fsh, farr) <--      compile "scatter" $-      liftA2 (,)-         (Code.createFunction callShaper "shape" $-          \paramPtr resultPtr -> do-            param <- Memory.load paramPtr-            case arrBase param of-               Core.Array esh _code -> do-                  sh <- unExp esh-                  MultiValueMemory.store sh resultPtr-                  Shape.sizeCode sh >>= LLVM.ret)-         (Code.createFunction callScatterer "fill" $-          \paramBasePtr paramMapPtr shapePtr bufferPtr -> do-            paramBase <- Memory.load paramBasePtr-            paramMap <- Memory.load paramMapPtr-            case (arrBase paramBase, arrMap paramMap) of-               (Core.Array esh codeBase, Core.Array eish codeMap) -> do-                  let clear ix p = do-                         flip Memory.store p =<< codeBase ix-                         A.advanceArrayElementPtr p-                  sh <- Shape.load esh shapePtr-                  void $ Shape.loop clear sh bufferPtr--                  ish <- unExp eish-                  let fill ix () = do-                         (jx, a) <- fmap MultiValue.unzip $ codeMap ix-                         p <- getElementPtr sh bufferPtr jx-                         flip Memory.store p-                            =<< Expr.unliftM2 (flip accum) a-                            =<< Memory.load p-                  Shape.loop fill ish ()-            LLVM.ret ())+scatter accum arrBase arrMap =+   PhysHull.scatter $+      liftA2 (PhysHull.Scatter accum)+         (Sym.arrayHull arrBase)+         (Sym.arrayHull arrMap) -   return $ \p ->-      bracket (createBase p) (deleteBase . fst) $ \(_ctxBase, paramBase) ->-      bracket (createMap p) (deleteMap . fst) $ \(_ctxMap, paramMap) ->-      alloca $ \shptr ->-      with paramBase $ \paramBasePtr -> do-      with paramMap $ \paramMapPtr -> do-         let paramBaseMVPtr = MultiValueMemory.castStructPtr paramBasePtr-         let paramMapMVPtr = MultiValueMemory.castStructPtr paramMapPtr-         let shapeMVPtr = MultiValueMemory.castStructPtr shptr-         n <- fsh paramBaseMVPtr shapeMVPtr-         fptr <- mallocForeignPtrArray (fromIntegral n)-         withForeignPtr fptr $-            farr paramBaseMVPtr paramMapMVPtr shapeMVPtr .-            MultiValueMemory.castStructPtr-         sh <- peek shptr-         return (Phys.Array sh fptr)+scatterMaybe ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    Storable sh1, MultiValueMemory.C sh1,+    Storable a, MultiValueMemory.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Sym.Array p sh1 a ->+   Sym.Array p sh0 (Maybe (ix1, a)) -> IO (p -> IO (Phys.Array sh1 a))+scatterMaybe accum arrBase arrMap =+   PhysHull.scatterMaybe $+      liftA2 (PhysHull.ScatterMaybe accum)+         (Sym.arrayHull arrBase)+         (Sym.arrayHull arrMap)  permute ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,
+ src/Data/Array/Knead/Parameterized/PhysicalHull.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Data.Array.Knead.Parameterized.PhysicalHull (+   render,+   Scatter(..),+   scatter,+   ScatterMaybe(..),+   scatterMaybe,+   MapAccumL(..),+   mapAccumL,+   FoldOuterL(..),+   foldOuterL,+   ) where++import qualified Data.Array.Knead.Parameterized.Private as Sym+import qualified Data.Array.Knead.Simple.PhysicalPrivate as Priv+import qualified Data.Array.Knead.Simple.Physical as Phys+import qualified Data.Array.Knead.Simple.Private as Core+import qualified Data.Array.Knead.Index.Nested.Shape as Shape+import qualified Data.Array.Knead.Code as Code+import Data.Array.Knead.Expression (Exp, unExp, )+import Data.Array.Knead.Code (compile, )++import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM++import Foreign.Marshal.Utils (with, )+import Foreign.Marshal.Alloc (alloca, )+import Foreign.Storable (Storable, peek, )+import Foreign.ForeignPtr (withForeignPtr, mallocForeignPtrArray, )+import Foreign.Ptr (FunPtr, Ptr, )++import Control.Exception (bracket, )+import Control.Monad.HT (void, )+import Control.Applicative (liftA2, )+import Data.Word (Word32, )+++type Importer f = FunPtr f -> f+++foreign import ccall safe "dynamic" callShaper ::+   Importer (Ptr param -> Ptr shape -> IO Word32)++foreign import ccall safe "dynamic" callFill ::+   Importer (Ptr param -> Ptr shape -> Ptr am -> IO ())++materialize ::+   (Shape.C sh, Storable sh, MultiValueMemory.C sh,+    Storable a, MultiValueMemory.C a) =>+   String ->+   (core -> Exp sh) ->+   (core ->+    LLVM.Value (Ptr (MultiValueMemory.Struct sh)) ->+    LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->+    LLVM.CodeGenFunction () ()) ->+   Sym.Hull p core -> IO (p -> IO (Phys.Array sh a))+materialize name shape fill (Sym.Hull core create delete) = do+   (fsh, farr) <-+      compile name $+      liftA2 (,)+         (Code.createFunction callShaper "shape" $+          \paramPtr resultPtr -> do+            param <- Memory.load paramPtr+            sh <- unExp $ shape $ core param+            MultiValueMemory.store sh resultPtr+            Shape.sizeCode sh >>= LLVM.ret)+         (Code.createFunction callFill "fill" $+          \paramPtr shapePtr bufferPtr -> do+            param <- Memory.load paramPtr+            fill (core param) shapePtr bufferPtr+            LLVM.ret ())++   return $ \p ->+      bracket (create p) (delete . fst) $ \(_ctx, param) ->+      alloca $ \shptr ->+      with param $ \paramPtr -> do+         let paramMVPtr = MultiValueMemory.castStructPtr paramPtr+         let shapeMVPtr = MultiValueMemory.castStructPtr shptr+         n <- fsh paramMVPtr shapeMVPtr+         fptr <- mallocForeignPtrArray (fromIntegral n)+         withForeignPtr fptr $+            farr paramMVPtr shapeMVPtr . MultiValueMemory.castStructPtr+         sh <- peek shptr+         return (Phys.Array sh fptr)+++render ::+   (Shape.C sh, Shape.Index sh ~ ix,+    Storable sh, MultiValueMemory.C sh,+    Storable a, MultiValueMemory.C a) =>+   Sym.Hull p (Core.Array sh a) -> IO (p -> IO (Phys.Array sh a))+render =+   materialize "render" Core.shape+      (\(Core.Array esh code) shapePtr bufferPtr -> do+         let step ix p = do+                flip Memory.store p =<< code ix+                A.advanceArrayElementPtr p+         sh <- Shape.load esh shapePtr+         void $ Shape.loop step sh bufferPtr)+++data Scatter sh0 sh1 a =+   Scatter {+      scatterAccum :: Exp a -> Exp a -> Exp a,+      scatterInit :: Core.Array sh1 a,+      scatterMap :: Core.Array sh0 (Shape.Index sh1, a)+   }++scatter ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    Storable sh1, MultiValueMemory.C sh1,+    Storable a, MultiValueMemory.C a) =>+   Sym.Hull p (Scatter sh0 sh1 a) -> IO (p -> IO (Phys.Array sh1 a))+scatter =+   materialize "scatter"+      (Core.shape . scatterInit)+      (\(Scatter accum arrInit arrMap) ->+         Priv.scatter accum arrInit arrMap)++++data ScatterMaybe sh0 sh1 a =+   ScatterMaybe {+      scatterMaybeAccum :: Exp a -> Exp a -> Exp a,+      scatterMaybeInit :: Core.Array sh1 a,+      scatterMaybeMap :: Core.Array sh0 (Maybe (Shape.Index sh1, a))+   }++scatterMaybe ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    Storable sh1, MultiValueMemory.C sh1,+    Storable a, MultiValueMemory.C a) =>+   Sym.Hull p (ScatterMaybe sh0 sh1 a) -> IO (p -> IO (Phys.Array sh1 a))+scatterMaybe =+   materialize "scatterMaybe"+      (Core.shape . scatterMaybeInit)+      (\(ScatterMaybe accum arrInit arrMap) ->+         Priv.scatterMaybe accum arrInit arrMap)+++data MapAccumL sh n acc a b =+   MapAccumL {+      mapAccumLAccum :: Exp acc -> Exp a -> Exp (acc,b),+      mapAccumLInit :: Core.Array sh acc,+      mapAccumLMap :: Core.Array (sh, n) a+   }++mapAccumL ::+   (Shape.C sh, Storable sh, MultiValueMemory.C sh,+    Shape.C n, Storable n, MultiValueMemory.C n,+    MultiValue.C acc,+    Storable a, MultiValueMemory.C a,+    Storable b, MultiValueMemory.C b) =>+   Sym.Hull p (MapAccumL sh n acc a b) -> IO (p -> IO (Phys.Array (sh,n) b))+mapAccumL =+   materialize "mapAccumL"+      (Core.shape . mapAccumLMap)+      (\(MapAccumL f arrInit arrData) -> Priv.mapAccumL f arrInit arrData)+++data FoldOuterL n sh a b =+   FoldOuterL {+      foldOuterLAccum :: Exp a -> Exp b -> Exp a,+      foldOuterLInit :: Core.Array sh a,+      foldOuterLMap :: Core.Array (n,sh) b+   }++-- FIXME: check correct size of array of initial values+foldOuterL ::+   (Shape.C sh, Storable sh, MultiValueMemory.C sh,+    Shape.C n, Storable n, MultiValueMemory.C n,+    Storable a, MultiValueMemory.C a) =>+   Sym.Hull p (FoldOuterL n sh a b) -> IO (p -> IO (Phys.Array sh a))+foldOuterL =+   materialize "foldOuterL"+      (Core.shape . foldOuterLInit)+      (\(FoldOuterL f arrInit arrData) -> Priv.foldOuterL f arrInit arrData)
src/Data/Array/Knead/Parameterized/Render.hs view
@@ -2,17 +2,27 @@ {- | Simplify running the @render@ function by handling passing of parameters. -}-module Data.Array.Knead.Parameterized.Render (run) where+module Data.Array.Knead.Parameterized.Render (+   run,+   Scatter(..),+   ScatterMaybe(..),+   MapAccumL(..),+   FoldOuterL(..),+   ) where +import qualified Data.Array.Knead.Parameterized.PhysicalHull as PhysHullP import qualified Data.Array.Knead.Parameterized.Physical as PhysP import qualified Data.Array.Knead.Parameterized.Private as Sym import qualified Data.Array.Knead.Simple.Physical as Phys import qualified Data.Array.Knead.Simple.Private as Core import qualified Data.Array.Knead.Parameter as Param import qualified Data.Array.Knead.Index.Nested.Shape as Shape+import Data.Array.Knead.Parameterized.PhysicalHull+         (Scatter, ScatterMaybe, MapAccumL, FoldOuterL) import Data.Array.Knead.Expression (Exp, )  import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory+import qualified LLVM.Extra.Multi.Value as MultiValue  import Foreign.Storable (Storable, ) @@ -31,7 +41,43 @@     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+   build = PhysHullP.render++instance+   (MultiValueMemory.C sh0, Storable sh0, Shape.C sh0,+    MultiValueMemory.C sh1, Storable sh1, Shape.C sh1,+    MultiValueMemory.C a, Storable a) =>+      C (Scatter sh0 sh1 a) where+   type Plain (Scatter sh0 sh1 a) = IO (Phys.Array sh1 a)+   build = PhysHullP.scatter++instance+   (MultiValueMemory.C sh0, Storable sh0, Shape.C sh0,+    MultiValueMemory.C sh1, Storable sh1, Shape.C sh1,+    MultiValueMemory.C a, Storable a) =>+      C (ScatterMaybe sh0 sh1 a) where+   type Plain (ScatterMaybe sh0 sh1 a) = IO (Phys.Array sh1 a)+   build = PhysHullP.scatterMaybe++instance+   (Shape.C sh, Storable sh, MultiValueMemory.C sh,+    Shape.C n, Storable n, MultiValueMemory.C n,+    MultiValue.C acc,+    Storable a, MultiValueMemory.C a,+    Storable b, MultiValueMemory.C b) =>+      C (MapAccumL sh n acc a b) where+   type Plain (MapAccumL sh n acc a b) = IO (Phys.Array (sh,n) b)+   build = PhysHullP.mapAccumL++instance+   (Shape.C sh, Storable sh, MultiValueMemory.C sh,+    Shape.C n, Storable n, MultiValueMemory.C n,+    Storable a, MultiValueMemory.C a,+    Storable b, MultiValueMemory.C b) =>+      C (FoldOuterL n sh a b) where+   type Plain (FoldOuterL n sh a b) = IO (Phys.Array sh a)+   build = PhysHullP.foldOuterL+  singleton :: Exp a -> Core.Array () a singleton = Core.fromScalar
src/Data/Array/Knead/Simple/Fold.hs view
@@ -1,7 +1,7 @@ {- | Reduce selected dimensions. Alternatively you may reorder dimensions with 'ShapeDep.backpermute'-and fold once along a multiple dimensions.+and fold once along multiple dimensions. -} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-}
src/Data/Array/Knead/Simple/Physical.hs view
@@ -9,10 +9,13 @@    with,    render,    scanl1,+   mapAccumL,    scatter,+   scatterMaybe,    permute,    ) where +import qualified Data.Array.Knead.Simple.PhysicalPrivate as Priv import qualified Data.Array.Knead.Simple.Private as Sym import qualified Data.Array.Knead.Index.Nested.Shape as Shape import qualified Data.Array.Knead.Expression as Expr@@ -23,7 +26,6 @@ import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Control as C import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Maybe as Maybe @@ -36,7 +38,7 @@ import Foreign.Ptr (FunPtr, Ptr, )  import Control.Monad.HT (void, )-import Control.Applicative (liftA2, )+import Control.Applicative (liftA2, (<$>), ) import Data.Word (Word32, )  import Prelude hiding (scanl1, )@@ -148,23 +150,52 @@     Storable a, MultiValueMemory.C a) =>    (Exp a -> Exp a -> Exp a) ->    Sym.Array (sh, Word32) a -> IO (Array (sh, Word32) a)-scanl1 f (Sym.Array esh code) =+scanl1 = scanl1Gen++scanl1Gen ::+   (Shape.C sh, Storable sh, MultiValueMemory.C sh,+    Shape.C n, Storable n, MultiValueMemory.C n,+    Storable a, MultiValueMemory.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Sym.Array (sh, n) a -> IO (Array (sh, n) a)+scanl1Gen f (Sym.Array esh code) =    materialize "scanl1" esh $ \sptr ptr -> do-      (sh, MultiValue.Cons n) <--         fmap MultiValue.unzip $ Shape.load esh sptr+      (sh, n) <- MultiValue.unzip <$> Shape.load esh sptr       let step ix ptrStart =-             fmap (fst.fst) $-             C.fixedLengthLoop n ((ptrStart, A.zero), Maybe.nothing) $ \((ptr0, k0), macc0) -> do-                a <- code (MultiValue.zip ix $ MultiValue.Cons k0)+             fmap fst $+             (\body -> Shape.loop body n (ptrStart, Maybe.nothing)) $+                   \k0 (ptr0, macc0) -> do+                a <- code $ MultiValue.zip ix k0                 acc1 <- Maybe.run macc0 (return a) (flip (Expr.unliftM2 f) a)-                flip Memory.store ptr0 acc1-                ptrK1 <--                   liftA2 (,)-                      (A.advanceArrayElementPtr ptr0)-                      (A.inc k0)-                return (ptrK1, Maybe.just acc1)+                Memory.store acc1 ptr0+                ptr1 <- A.advanceArrayElementPtr ptr0+                return (ptr1, Maybe.just acc1)       void $ Shape.loop step sh ptr +mapAccumL ::+   (Shape.C sh, Storable sh, MultiValueMemory.C sh,+    Shape.C n, Storable n, MultiValueMemory.C n,+    MultiValue.C acc,+    Storable x, MultiValueMemory.C x,+    Storable y, MultiValueMemory.C y) =>+   (Exp acc -> Exp x -> Exp (acc,y)) ->+   Sym.Array sh acc -> Sym.Array (sh, n) x -> IO (Array (sh, n) y)+mapAccumL f arrInit arrData =+   materialize "mapAccumL" (Sym.shape arrData) $+      Priv.mapAccumL f arrInit arrData++scatterMaybe ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    Storable sh1, MultiValueMemory.C sh1,+    Storable a, MultiValueMemory.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Sym.Array sh1 a ->+   Sym.Array sh0 (Maybe (ix1, a)) -> IO (Array sh1 a)+scatterMaybe accum arrInit arrMap =+   materialize "scatterMaybe" (Sym.shape arrInit) $+      Priv.scatterMaybe accum arrInit arrMap+ scatter ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,     Shape.C sh1, Shape.Index sh1 ~ ix1,@@ -173,22 +204,9 @@    (Exp a -> Exp a -> Exp a) ->    Sym.Array sh1 a ->    Sym.Array sh0 (ix1, a) -> IO (Array sh1 a)-scatter accum (Sym.Array esh defltCode) (Sym.Array eish code) =-   materialize "scatter" esh $ \sptr ptr -> do-      let clear ix p = do-             flip Memory.store p =<< defltCode ix-             A.advanceArrayElementPtr p-      sh <- Shape.load esh sptr-      void $ Shape.loop clear sh ptr--      ish <- unExp eish-      let fill ix () = do-             (jx, a) <- fmap MultiValue.unzip $ code ix-             p <- getElementPtr sh ptr jx-             flip Memory.store p-                =<< Expr.unliftM2 (flip accum) a-                =<< Memory.load p-      void $ Shape.loop fill ish ()+scatter accum arrInit arrMap =+   materialize "scatter" (Sym.shape arrInit) $+      Priv.scatter accum arrInit arrMap  permute ::    (Shape.C sh0, Shape.Index sh0 ~ ix0,
+ src/Data/Array/Knead/Simple/PhysicalPrivate.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Array.Knead.Simple.PhysicalPrivate where++import qualified Data.Array.Knead.Simple.Private as Sym+import qualified Data.Array.Knead.Index.Nested.Shape as Shape+import qualified Data.Array.Knead.Expression as Expr+import Data.Array.Knead.Expression (Exp, unExp)+import Data.Array.Knead.Code (getElementPtr)++import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory+import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Memory as Memory++import qualified LLVM.Core as LLVM++import Foreign.Storable (Storable, )+import Foreign.Ptr (Ptr, )++import Control.Monad.HT (void, )+import Control.Applicative ((<$>), )++import Data.Tuple.HT (mapSnd, )++++mapAccumL ::+   (Shape.C sh, Storable sh, MultiValueMemory.C sh,+    Shape.C n, Storable n, MultiValueMemory.C n,+    MultiValue.C acc,+    Storable x, MultiValueMemory.C x,+    Storable y, MultiValueMemory.C y) =>+   (Exp acc -> Exp x -> Exp (acc,y)) ->+   Sym.Array sh acc -> Sym.Array (sh, n) x ->+   LLVM.Value (Ptr (MultiValueMemory.Struct (sh,n))) ->+   LLVM.Value (Ptr (MultiValueMemory.Struct y)) ->+   LLVM.CodeGenFunction r ()+mapAccumL f (Sym.Array _ initCode) (Sym.Array esh code) sptr ptr = do+   (sh, n) <- MultiValue.unzip <$> Shape.load esh sptr+   let step ix ptrStart = do+         accInit <- initCode ix+         fmap fst $+          (\body -> Shape.loop body n (ptrStart, accInit)) $+                \k0 (ptr0, acc0) -> do+             x <- code $ MultiValue.zip ix k0+             (acc1,y) <- MultiValue.unzip <$> Expr.unliftM2 f acc0 x+             Memory.store y ptr0+             ptr1 <- A.advanceArrayElementPtr ptr0+             return (ptr1, acc1)+   void $ Shape.loop step sh ptr++foldOuterL ::+   (Shape.C sh, Storable sh, MultiValueMemory.C sh,+    Shape.C n, Storable n, MultiValueMemory.C n,+    MultiValueMemory.C a) =>+   (Exp a -> Exp b -> Exp a) ->+   Sym.Array sh a -> Sym.Array (n,sh) b ->+   LLVM.Value (Ptr (MultiValueMemory.Struct sh)) ->+   LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->+   LLVM.CodeGenFunction r ()+foldOuterL f (Sym.Array _ initCode) (Sym.Array esh code) _sptr ptr = do+   -- (n,sh) <- MultiValue.unzip <$> Shape.load esh sptr+   (n,sh) <- MultiValue.unzip <$> unExp esh+   let fillInit ix ptr0 = do+         a <- initCode ix+         Memory.store a ptr0+         A.advanceArrayElementPtr ptr0+   void $ Shape.loop fillInit sh ptr++   let step k ix ptr0 = do+       b <- code $ MultiValue.zip k ix+       a0 <- Memory.load ptr0+       a1 <- Expr.unliftM2 f a0 b+       Memory.store a1 ptr0+       A.advanceArrayElementPtr ptr0+   void $ Shape.loop (\k () -> void $ Shape.loop (step k) sh ptr) n ()++scatterMaybe ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    Storable sh1, MultiValueMemory.C sh1,+    Storable a, MultiValueMemory.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Sym.Array sh1 a -> Sym.Array sh0 (Maybe (ix1, a)) ->+   LLVM.Value (Ptr (MultiValueMemory.Struct sh1)) ->+   LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->+   LLVM.CodeGenFunction r ()+scatterMaybe accum (Sym.Array esh codeInit) (Sym.Array eish codeMap)+      sptr ptr = do++   let clear ix p = do+         flip Memory.store p =<< codeInit ix+         A.advanceArrayElementPtr p+   sh <- Shape.load esh sptr+   void $ Shape.loop clear sh ptr++   ish <- unExp eish+   let fill ix () = do+         (MultiValue.Cons c, (jx, a)) <-+            mapSnd MultiValue.unzip . MultiValue.splitMaybe <$> codeMap ix+         C.ifThen c () $ do+            p <- getElementPtr sh ptr jx+            flip Memory.store p+               =<< Expr.unliftM2 (flip accum) a+               =<< Memory.load p+   Shape.loop fill ish ()++scatter ::+   (Shape.C sh0, Shape.Index sh0 ~ ix0,+    Shape.C sh1, Shape.Index sh1 ~ ix1,+    Storable sh1, MultiValueMemory.C sh1,+    Storable a, MultiValueMemory.C a) =>+   (Exp a -> Exp a -> Exp a) ->+   Sym.Array sh1 a ->+   Sym.Array sh0 (Shape.Index sh1, a) ->+   LLVM.Value (Ptr (MultiValueMemory.Struct sh1)) ->+   LLVM.Value (Ptr (MultiValueMemory.Struct a)) ->+   LLVM.CodeGenFunction r ()+scatter accum (Sym.Array esh codeInit) (Sym.Array eish codeMap) sptr ptr = do+   let clear ix p = do+         flip Memory.store p =<< codeInit ix+         A.advanceArrayElementPtr p+   sh <- Shape.load esh sptr+   void $ Shape.loop clear sh ptr++   ish <- unExp eish+   let fill ix () = do+         (jx, a) <- fmap MultiValue.unzip $ codeMap ix+         p <- getElementPtr sh ptr jx+         flip Memory.store p+            =<< Expr.unliftM2 (flip accum) a+            =<< Memory.load p+   Shape.loop fill ish ()
src/Data/Array/Knead/Simple/Private.hs view
@@ -9,6 +9,7 @@ import qualified LLVM.Extra.Multi.Value as MultiValue import qualified LLVM.Extra.Monad as Monad import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.Control as C import qualified LLVM.Core as LLVM  import qualified Control.Category as Cat@@ -148,6 +149,48 @@       (Expr.lift1 (MultiValue.zip (MultiValue.Cons ())) esh)       (code . MultiValue.snd) ++{-+'Shape.loop' does not support an early exit.+I wished the LLVM optimizer would rewrite the loop accordingly.+Unfortunately, it does not.+-}+findAllCode ::+   (Shape.C sh, Shape.Index sh ~ ix, MultiValue.C a) =>+   (Exp a -> Exp Bool) ->+   Exp sh ->+   (Val ix -> Code r a) ->+   Code r (Maybe a)+findAllCode p (Exp sh) code = do+   n <- sh+   finalFound <-+      Shape.loop+         (\i found ->+            C.ifThenElse (Maybe.isJust found)+               (return found)+               (do+                  a <- code i+                  MultiValue.Cons b <- Expr.unliftM1 p a+                  return $ Maybe.fromBool b a))+         n Maybe.nothing+   Maybe.run finalFound+      (return MultiValue.nothing)+      (return . MultiValue.just)++{- |+In principle this can be implemented using fold1All+but this one should have short-cut semantics.+Currently it has not! :-(+@All@ means that it scans all dimensions+but it does not mean that it finds all occurrences.+If you want to get the index of the found element,+please decorate the array elements with their indices before calling 'findAll'.+-}+findAll ::+   (Shape.C sh, MultiValue.C a) =>+   (Exp a -> Exp Bool) ->+   Array sh a -> Exp (Maybe a)+findAll p (Array sh code) = Exp (findAllCode p sh code)   class Process proc where
src/Data/Array/Knead/Simple/Slice.hs view
@@ -52,8 +52,18 @@    passAny,    pass,    pick,+   pickFst,+   pickSnd,    extrude,+   extrudeFst,+   extrudeSnd,+   transpose,    (Core.$:.),++   id,+   first,+   second,+   compose,    ) where  import qualified Data.Array.Knead.Simple.ShapeDependent as ShapeDep@@ -68,7 +78,8 @@ import qualified LLVM.Extra.Multi.Value as MultiValue import LLVM.Extra.Multi.Value (atom, ) -import Prelude hiding (zipWith, zipWith3, zip, zip3, replicate, )+import qualified Prelude as P+import Prelude hiding (id, zipWith, zipWith3, zip, zip3, replicate, )   @@ -96,13 +107,51 @@    ShapeDep.backpermute fsh fix  +pickFst :: Exp (Shape.Index n) -> T (n,sh) sh+pickFst i = Cons Expr.snd (Expr.zip i)++pickSnd :: Exp (Shape.Index n) -> T (sh,n) sh+pickSnd i = Cons Expr.fst (flip Expr.zip i)++{- |+Extrusion has the potential to do duplicate work.+Only use it to add dimensions of size 1, e.g. numeric 1 or unit @()@+or to duplicate slices of physical arrays.+-}+extrudeFst :: Exp n -> T sh (n,sh)+extrudeFst n = Cons (Expr.zip n) Expr.snd++extrudeSnd :: Exp n -> T sh (sh,n)+extrudeSnd n = Cons (flip Expr.zip n) Expr.fst++transpose :: T (sh0,sh1) (sh1,sh0)+transpose = Cons Expr.swap Expr.swap+++-- Arrow combinators++id :: T sh sh+id = Cons P.id P.id++first :: T sh0 sh1 -> T (sh0,sh) (sh1,sh)+first (Cons fsh fix) = Cons (Expr.mapFst fsh) (Expr.mapFst fix)++second :: T sh0 sh1 -> T (sh,sh0) (sh,sh1)+second (Cons fsh fix) = Cons (Expr.mapSnd fsh) (Expr.mapSnd fix)++infixr 1 `compose`++compose :: T sh0 sh1 -> T sh1 sh2 -> T sh0 sh2+compose (Cons fshA fixA) (Cons fshB fixB) = Cons (fshB . fshA) (fixA . fixB)++ type Linear sh0 sh1 = T (Linear.Shape sh0) (Linear.Shape sh1)  {- | Like @Any@ in @accelerate@. -} passAny :: Linear sh sh-passAny = Cons id id+passAny = Cons P.id P.id  {- | Like @All@ in @accelerate@.
src/Data/Array/Knead/Simple/Symbolic.hs view
@@ -23,6 +23,7 @@    zip4,    fold1,    fold1All,+   Core.findAll,    ) where  import qualified Data.Array.Knead.Simple.ShapeDependent as ShapeDep