packages feed

accelerate-utility (empty) → 0.0

raw patch · 8 files changed

+618/−0 lines, 8 filesdep +acceleratedep +basedep +utility-htsetup-changed

Dependencies added: accelerate, base, utility-ht

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Henning Thielemann 2014++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ accelerate-utility.cabal view
@@ -0,0 +1,40 @@+Name:             accelerate-utility+Version:          0.0+License:          BSD3+License-File:     LICENSE+Author:           Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>+Homepage:         http://code.haskell.org/~thielema/accelerate-utility/+Category:         Parallelism+Synopsis:         Utility functions for the Accelerate framework+Description:+  Several utility functions on top of the Accelerate framework.+  The functions simplify working with indices and lifting and unlifting.+Tested-With:      GHC==7.8.3+Cabal-Version:    >=1.14+Build-Type:       Simple++Source-Repository this+  Tag:         0.0+  Type:        darcs+  Location:    http://code.haskell.org/~thielema/accelerate-utility/++Source-Repository head+  Type:        darcs+  Location:    http://code.haskell.org/~thielema/accelerate-utility/++Library+  Build-Depends:+    accelerate >=0.15 && <0.16,+    utility-ht >=0.0.8 && <0.1,+    base >=4.5 && <4.8++  GHC-Options:      -Wall -fwarn-missing-import-lists+  Hs-Source-Dirs:   src+  Default-Language: Haskell98+  Exposed-Modules:+    Data.Array.Accelerate.Utility.Lift.Acc+    Data.Array.Accelerate.Utility.Lift.Exp+    Data.Array.Accelerate.Utility.Lift.Run+    Data.Array.Accelerate.Utility.Loop+    Data.Array.Accelerate.Utility.Arrange
+ src/Data/Array/Accelerate/Utility/Arrange.hs view
@@ -0,0 +1,31 @@+module Data.Array.Accelerate.Utility.Arrange (+   mapWithIndex,+   gather,+   scatter,+   ) where++import qualified Data.Array.Accelerate as A+import Data.Array.Accelerate (Acc, Array, Exp)+++mapWithIndex ::+   (A.Shape sh, A.Elt a, A.Elt b) =>+   (Exp sh -> Exp a -> Exp b) ->+   Acc (Array sh a) -> Acc (Array sh b)+mapWithIndex f xs =+   A.zipWith f (A.generate (A.shape xs) id) xs+++gather ::+   (A.Shape ix, A.Shape ix', A.Elt ix', A.Elt a) =>+   Acc (Array ix ix') -> Acc (Array ix' a) -> Acc (Array ix a)+gather indices xs =+   A.map (xs A.!) indices++scatter ::+   (A.Shape ix, A.Shape ix', A.Elt ix', A.Elt a) =>+   (Exp a -> Exp a -> Exp a) ->+   Acc (Array ix ix') -> Acc (Array ix' a) ->+   Acc (Array ix a) -> Acc (Array ix' a)+scatter f indices deflt xs =+   A.permute f deflt (indices A.!) xs
+ src/Data/Array/Accelerate/Utility/Lift/Acc.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module Data.Array.Accelerate.Utility.Lift.Acc (+   Unlift,+   Unlifted,+   Tuple,+   unlift,+   modify,+   modify2,+   modify3,+   modify4,+   Acc(Acc), acc,+   Exp(Exp), expr,+   unliftPair,+   unliftTriple,+   unliftQuadruple,+   mapFst,+   mapSnd,+   singleton,+   the,+   ) where++import qualified Data.Array.Accelerate as A++import qualified Data.Tuple.HT as Tuple+import Data.Tuple.HT (mapTriple)+++class (A.Arrays (Tuple pattern)) => Unlift pattern where+   type Unlifted pattern+   type Tuple pattern+   unlift :: pattern -> A.Acc (Tuple pattern) -> Unlifted pattern++modify ::+   (A.Lift A.Acc a, Unlift pattern) =>+   pattern ->+   (Unlifted pattern -> a) ->+   A.Acc (Tuple pattern) -> A.Acc (A.Plain a)+modify p f = A.lift . f . unlift p++modify2 ::+   (A.Lift A.Acc a, Unlift patternA, Unlift patternB) =>+   patternA ->+   patternB ->+   (Unlifted patternA -> Unlifted patternB -> a) ->+   A.Acc (Tuple patternA) -> A.Acc (Tuple patternB) -> A.Acc (A.Plain a)+modify2 pa pb f a b = A.lift $ f (unlift pa a) (unlift pb b)++modify3 ::+   (A.Lift A.Acc a, Unlift patternA, Unlift patternB, Unlift patternC) =>+   patternA ->+   patternB ->+   patternC ->+   (Unlifted patternA -> Unlifted patternB -> Unlifted patternC -> a) ->+   A.Acc (Tuple patternA) -> A.Acc (Tuple patternB) ->+   A.Acc (Tuple patternC) -> A.Acc (A.Plain a)+modify3 pa pb pc f a b c =+   A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c)++modify4 ::+   (A.Lift A.Acc a,+    Unlift patternA, Unlift patternB, Unlift patternC, Unlift patternD) =>+   patternA ->+   patternB ->+   patternC ->+   patternD ->+   (Unlifted patternA -> Unlifted patternB ->+    Unlifted patternC -> Unlifted patternD -> a) ->+   A.Acc (Tuple patternA) -> A.Acc (Tuple patternB) ->+   A.Acc (Tuple patternC) -> A.Acc (Tuple patternD) -> A.Acc (A.Plain a)+modify4 pa pb pc pd f a b c d =+   A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c) (unlift pd d)+++instance (A.Arrays a) => Unlift (Acc a) where+   type Unlifted (Acc a) = A.Acc a+   type Tuple (Acc a) = a+   unlift _ = id++data Acc a = Acc++acc :: Acc a+acc = Acc+++instance (A.Elt a) => Unlift (Exp a) where+   type Unlifted (Exp a) = A.Exp a+   type Tuple (Exp a) = A.Scalar a+   unlift _ = A.the++data Exp e = Exp++expr :: Exp e+expr = Exp+++-- | like 'A.unit' in the 'Acc' environment+singleton :: (A.Elt e) => e -> A.Scalar e+singleton x = A.fromList A.Z [x]++-- | like 'A.the' in the 'Acc' environment+the :: (A.Elt e) => A.Scalar e -> e+the arr = A.indexArray arr A.Z+++instance (Unlift pa, Unlift pb) => Unlift (pa,pb) where+   type Unlifted (pa,pb) = (Unlifted pa, Unlifted pb)+   type Tuple (pa,pb) = (Tuple pa, Tuple pb)+   unlift (pa,pb) ab =+      (unlift pa $ A.afst ab, unlift pb $ A.asnd ab)++instance+   (Unlift pa, Unlift pb, Unlift pc) =>+      Unlift (pa,pb,pc) where+   type Unlifted (pa,pb,pc) = (Unlifted pa, Unlifted pb, Unlifted pc)+   type Tuple (pa,pb,pc) = (Tuple pa, Tuple pb, Tuple pc)+   unlift (pa,pb,pc) =+      mapTriple (unlift pa, unlift pb, unlift pc) . A.unlift++++unliftPair :: (A.Arrays a, A.Arrays b) => A.Acc (a,b) -> (A.Acc a, A.Acc b)+unliftPair = A.unlift++unliftTriple ::+   (A.Arrays a, A.Arrays b, A.Arrays c) => A.Acc (a,b,c) -> (A.Acc a, A.Acc b, A.Acc c)+unliftTriple = A.unlift++unliftQuadruple ::+   (A.Arrays a, A.Arrays b, A.Arrays c, A.Arrays d) =>+   A.Acc (a,b,c,d) -> (A.Acc a, A.Acc b, A.Acc c, A.Acc d)+unliftQuadruple = A.unlift+++mapFst ::+   (A.Arrays a, A.Arrays b, A.Arrays c) =>+   (A.Acc a -> A.Acc b) -> A.Acc (a,c) -> A.Acc (b,c)+mapFst f = modify (acc,acc) $ Tuple.mapFst f++mapSnd ::+   (A.Arrays a, A.Arrays b, A.Arrays c) =>+   (A.Acc b -> A.Acc c) -> A.Acc (a,b) -> A.Acc (a,c)+mapSnd f = modify (acc,acc) $ Tuple.mapSnd f
+ src/Data/Array/Accelerate/Utility/Lift/Exp.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+module Data.Array.Accelerate.Utility.Lift.Exp (+   Unlift,+   Unlifted,+   Tuple,+   unlift,+   modify,+   modify2,+   modify3,+   modify4,+   Atom(Atom), atom,+   unliftPair,+   unliftTriple,+   unliftQuadruple,+   asExp,+   mapFst,+   mapSnd,+   fst3,+   snd3,+   thd3,+   indexCons,+   ) where++import qualified Data.Array.Accelerate as A+import Data.Array.Accelerate (Exp, (:.)((:.)))++import qualified Data.Tuple.HT as Tuple+import Data.Tuple.HT (mapTriple)+++class+   (A.Elt (Tuple pattern), A.Plain (Unlifted pattern) ~ Tuple pattern) =>+      Unlift pattern where+   type Unlifted pattern+   type Tuple pattern+   unlift :: pattern -> Exp (Tuple pattern) -> Unlifted pattern++modify ::+   (A.Lift Exp a, Unlift pattern) =>+   pattern ->+   (Unlifted pattern -> a) ->+   Exp (Tuple pattern) -> Exp (A.Plain a)+modify p f = A.lift . f . unlift p++modify2 ::+   (A.Lift Exp a, Unlift patternA, Unlift patternB) =>+   patternA ->+   patternB ->+   (Unlifted patternA -> Unlifted patternB -> a) ->+   Exp (Tuple patternA) -> Exp (Tuple patternB) -> Exp (A.Plain a)+modify2 pa pb f a b = A.lift $ f (unlift pa a) (unlift pb b)++modify3 ::+   (A.Lift Exp a, Unlift patternA, Unlift patternB, Unlift patternC) =>+   patternA ->+   patternB ->+   patternC ->+   (Unlifted patternA -> Unlifted patternB -> Unlifted patternC -> a) ->+   Exp (Tuple patternA) -> Exp (Tuple patternB) ->+   Exp (Tuple patternC) -> Exp (A.Plain a)+modify3 pa pb pc f a b c =+   A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c)++modify4 ::+   (A.Lift Exp a,+    Unlift patternA, Unlift patternB, Unlift patternC, Unlift patternD) =>+   patternA ->+   patternB ->+   patternC ->+   patternD ->+   (Unlifted patternA -> Unlifted patternB ->+    Unlifted patternC -> Unlifted patternD -> a) ->+   Exp (Tuple patternA) -> Exp (Tuple patternB) ->+   Exp (Tuple patternC) -> Exp (Tuple patternD) -> Exp (A.Plain a)+modify4 pa pb pc pd f a b c d =+   A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c) (unlift pd d)+++instance (A.Elt a) => Unlift (Atom a) where+   type Unlifted (Atom a) = Exp a+   type Tuple (Atom a) = a+   unlift _ = id++data Atom a = Atom++atom :: Atom a+atom = Atom+++instance (Unlift pa, Unlift pb) => Unlift (pa,pb) where+   type Unlifted (pa,pb) = (Unlifted pa, Unlifted pb)+   type Tuple (pa,pb) = (Tuple pa, Tuple pb)+   unlift (pa,pb) ab =+      (unlift pa $ A.fst ab, unlift pb $ A.snd ab)++instance+   (Unlift pa, Unlift pb, Unlift pc) =>+      Unlift (pa,pb,pc) where+   type Unlifted (pa,pb,pc) = (Unlifted pa, Unlifted pb, Unlifted pc)+   type Tuple (pa,pb,pc) = (Tuple pa, Tuple pb, Tuple pc)+   unlift (pa,pb,pc) =+      mapTriple (unlift pa, unlift pb, unlift pc) . A.unlift+++instance (Unlift pa, A.Slice (Tuple pa), int ~ Atom Int) => Unlift (pa :. int) where+   type Unlifted (pa :. int) = Unlifted pa :. Exp Int+   type Tuple (pa :. int) = Tuple pa :. Int+   unlift (pa:.pb) ab =+      (unlift pa $ A.indexTail ab) :. (unlift pb $ A.indexHead ab)+++unliftPair :: (A.Elt a, A.Elt b) => Exp (a,b) -> (Exp a, Exp b)+unliftPair = A.unlift++unliftTriple ::+   (A.Elt a, A.Elt b, A.Elt c) => Exp (a,b,c) -> (Exp a, Exp b, Exp c)+unliftTriple = A.unlift++unliftQuadruple ::+   (A.Elt a, A.Elt b, A.Elt c, A.Elt d) =>+   Exp (a,b,c,d) -> (Exp a, Exp b, Exp c, Exp d)+unliftQuadruple = A.unlift++asExp :: Exp a -> Exp a+asExp = id++mapFst ::+   (A.Elt a, A.Elt b, A.Elt c) =>+   (Exp a -> Exp b) -> Exp (a,c) -> Exp (b,c)+mapFst f = modify (atom,atom) $ \(a,c) -> (f a, c)++mapSnd ::+   (A.Elt a, A.Elt b, A.Elt c) =>+   (Exp b -> Exp c) -> Exp (a,b) -> Exp (a,c)+mapSnd f = modify (atom,atom) $ \(a,b) -> (a, f b)+++fst3 ::+   (A.Elt a, A.Elt b, A.Elt c) =>+   Exp (a,b,c) -> Exp a+fst3 = modify (atom,atom,atom) Tuple.fst3++snd3 ::+   (A.Elt a, A.Elt b, A.Elt c) =>+   Exp (a,b,c) -> Exp b+snd3 = modify (atom,atom,atom) Tuple.snd3++thd3 ::+   (A.Elt a, A.Elt b, A.Elt c) =>+   Exp (a,b,c) -> Exp c+thd3 = modify (atom,atom,atom) Tuple.thd3++++indexCons ::+   (A.Slice ix) => Exp ix -> Exp Int -> Exp (ix :. Int)+indexCons ix n = A.lift $ ix:.n
+ src/Data/Array/Accelerate/Utility/Lift/Run.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}+{- |+Simplify running @accelerate@ functions+with multiple curried array and expression arguments.+-}+module Data.Array.Accelerate.Utility.Lift.Run (+   C(..), with,+   Argument(..),+   ) where++import qualified Data.Array.Accelerate.Utility.Lift.Acc as Acc++import qualified Data.Array.Accelerate as A+import Data.Array.Accelerate (Acc, Exp, Z, (:.))++import Data.Tuple.HT (mapPair, mapTriple)+++merge ::+   (A.Arrays a, A.Arrays packed) =>+   (Acc packed -> b) ->+   (Acc a -> b -> c) -> (Acc (a,packed) -> c)+merge unpack f arr = f (A.afst arr) (unpack $ A.asnd arr)++_mergeAcc ::+   (A.Arrays a, A.Arrays b) =>+   (Acc a -> Acc b -> c) -> (Acc (a,b) -> c)+_mergeAcc f arr = f (A.afst arr) (A.asnd arr)++_mergeExp ::+   (A.Elt a, A.Arrays b) =>+   (Exp a -> Acc b -> c) -> (Acc (A.Scalar a, b) -> c)+_mergeExp f arr = f (A.the $ A.afst arr) (A.asnd arr)++_mergeExpR ::+   (A.Arrays a, A.Elt b) =>+   (Acc a -> Exp b -> c) -> (Acc (a, A.Scalar b) -> c)+_mergeExpR f arr = f (A.afst arr) (A.the $ A.asnd arr)+++split ::+   (A.Arrays a, A.Arrays packed) =>+   (unpacked -> packed) ->+   ((a, packed) -> c) -> (a -> unpacked -> c)+split pack f a b = f (a, pack b)++_splitAcc :: ((a,b) -> c) -> (a -> b -> c)+_splitAcc = curry++_splitExp :: (A.Elt a) => ((A.Scalar a, b) -> c) -> (a -> b -> c)+_splitExp f a b = f (Acc.singleton a, b)++_splitExpR :: (A.Elt b) => ((a, A.Scalar b) -> c) -> (a -> b -> c)+_splitExpR f a b = f (a, Acc.singleton b)++++{-+(Acc ((a,b),c)) -> Acc d) -> (((a,b),c) -> d)+(Acc (a,b) -> Acc c -> Acc d) -> ((a,b) -> c -> d)+(Acc a -> Acc b -> Acc c -> Acc d) -> (a -> b -> c -> d)+-}+class C f where+   type Arguments a f+   type Result f+   type Plain f+   with1 ::+      (A.Arrays a) =>+      ((Acc (Arguments a f) -> Acc (Result f)) ->+       ((Arguments a f) -> Result f)) ->+      (Acc a -> f) -> a -> Plain f++with ::+   (C f) =>+   ((Acc (Arguments () f) -> Acc (Result f)) ->+    ((Arguments () f) -> Result f)) ->+   f -> Plain f+with run f = with1 run (const f) ()+++instance C (Acc r) where+   type Arguments a (Acc r) = a+   type Result (Acc r) = r+   type Plain (Acc r) = r+   with1 run f = run f++instance+   (A.Lift Acc r, A.Arrays (A.Plain r),+    A.Lift Acc s, A.Arrays (A.Plain s)) =>+      C (r,s) where+   type Arguments a (r,s) = a+   type Result (r,s) = (A.Plain r, A.Plain s)+   type Plain (r,s) = (A.Plain r, A.Plain s)+   with1 run f = run (A.lift . f)++instance+   (A.Lift Acc r, A.Arrays (A.Plain r),+    A.Lift Acc s, A.Arrays (A.Plain s),+    A.Lift Acc t, A.Arrays (A.Plain t)) =>+      C (r,s,t) where+   type Arguments a (r,s,t) = a+   type Result (r,s,t) = (A.Plain r, A.Plain s, A.Plain t)+   type Plain (r,s,t) = (A.Plain r, A.Plain s, A.Plain t)+   with1 run f = run (A.lift . f)++++instance (Argument arg, C f) => C (arg -> f) where+   type Arguments a (arg -> f) = Arguments (a, Packed arg) f+   type Result (arg -> f) = Result f+   type Plain (arg -> f) = Unpacked arg -> Plain f+   with1 run f =+      case tunnel of+         (pack, unpack) ->+            split pack (with1 run $ merge unpack f)+++class (A.Arrays (Packed a)) => Argument a where+   type Packed a+   type Unpacked a+   tunnel :: (Unpacked a -> Packed a, Acc (Packed a) -> a)++instance (A.Arrays a) => Argument (Acc a) where+   type Packed (Acc a) = a+   type Unpacked (Acc a) = a+   tunnel = (id, id)++instance (A.Elt a) => Argument (Exp a) where+   type Packed (Exp a) = A.Scalar a+   type Unpacked (Exp a) = a+   tunnel = (Acc.singleton, A.the)++instance (Argument a, Argument b) => Argument (a,b) where+   type Packed (a,b) = (Packed a, Packed b)+   type Unpacked (a,b) = (Unpacked a, Unpacked b)+   tunnel =+      case (tunnel, tunnel) of+         ((packA, unpackA), (packB, unpackB)) ->+            (mapPair (packA,packB),+             mapPair (unpackA,unpackB) . A.unlift)++instance (Argument a, Argument b, Argument c) => Argument (a,b,c) where+   type Packed (a,b,c) = (Packed a, Packed b, Packed c)+   type Unpacked (a,b,c) = (Unpacked a, Unpacked b, Unpacked c)+   tunnel =+      case (tunnel, tunnel, tunnel) of+         ((packA, unpackA), (packB, unpackB), (packC, unpackC)) ->+            (mapTriple (packA,packB,packC),+             mapTriple (unpackA,unpackB,unpackC) . A.unlift)+++instance Argument Z where+   type Packed Z = A.Scalar Z+   type Unpacked Z = Z+   tunnel = (Acc.singleton, A.unlift . A.the)++instance+   (A.Unlift Exp a, A.Lift Exp a, A.Slice (A.Plain a), b ~ Exp Int) =>+      Argument (a:.b) where+   type Packed (a:.b) = A.Scalar (A.Plain a :. Int)+   type Unpacked (a:.b) = A.Plain a :. Int+   tunnel = (Acc.singleton, A.unlift . A.the)+
+ src/Data/Array/Accelerate/Utility/Loop.hs view
@@ -0,0 +1,47 @@+module Data.Array.Accelerate.Utility.Loop (+   nest,+   nestLog2,+   ) where++import qualified Data.Array.Accelerate as A+import Data.Array.Accelerate (Acc, Exp)++++nest, _nest ::+   (A.Arrays a) =>+   Exp Int -> (Acc a -> Acc a) -> Acc a -> Acc a+nest n0 f x0 =+   A.asnd $+   A.awhile+      (A.map (A.>* 0) . A.afst)+      (A.lift . (\(n, x) -> (A.map (subtract 1) n, f x)) . A.unlift)+      (A.lift (A.unit n0, x0))++_nest n0 f x0 =+   A.asnd $+   A.awhile+      (A.unit . (A.>* 0) . A.the . A.afst)+      (A.lift . (\(n, x) -> (A.unit $ A.the n - 1, f x)) . A.unlift)+      (A.lift (A.unit n0, x0))+++nestLog2, _nestLog2 ::+   (A.Arrays a) =>+   Exp Int -> (Acc a -> Acc a) -> Acc a -> Acc a+nestLog2 n0 f x0 =+   A.asnd $+   A.awhile+      (A.map (A.>* 1) . A.afst)+      (A.lift . (\(n, x) -> (A.map (flip div 2 . (1+)) n, f x)) . A.unlift)+      (A.lift (A.unit n0, x0))++{-+This is an infinite loop,+because A.acond always has to generate code for both branches.+-}+_nestLog2 n0 f x0 =+   let go n x =+          A.acond (n A.<=* 1) x $+          go (div (n+1) 2) (f x)+   in  go n0 x0