diff --git a/Data/Array/Parallel.hs b/Data/Array/Parallel.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel.hs @@ -0,0 +1,867 @@ +{-# LANGUAGE ParallelArrays #-} +{-# OPTIONS_GHC -fvectorise #-} + +-- | User level interface of parallel arrays. +-- +-- The semantic difference between standard Haskell arrays (aka "lazy +-- arrays") and parallel arrays (aka "strict arrays") is that the evaluation +-- of two different elements of a lazy array is independent, whereas in a +-- strict array either non or all elements are evaluated. In other words, +-- when a parallel array is evaluated to WHNF, all its elements will be +-- evaluated to WHNF. The name parallel array indicates that all array +-- elements may, in general, be evaluated to WHNF in parallel without any +-- need to resort to speculative evaluation. This parallel evaluation +-- semantics is also beneficial in the sequential case, as it facilitates +-- loop-based array processing as known from classic array-based languages, +-- such as Fortran. +-- +-- The interface of this module is essentially a variant of the list +-- component of the Prelude, but also includes some functions (such as +-- permutations) that are not provided for lists. The following list of +-- operations are not supported on parallel arrays, as they would require the +-- infinite parallel arrays: `iterate', `repeat', and `cycle'. +-- +-- /WARNING:/ In the current implementation, the functionality provided in +-- this module is tied to the vectoriser pass of GHC invoked by passing the +-- `-fvectorise` option. Without vectorisation these functions will not work +-- at all! + +module Data.Array.Parallel ( + module Data.Array.Parallel.Prelude, + + -- [::], -- Built-in syntax + + -- * Operations on parallel arrays '[::]' + emptyP, singletonP, replicateP, lengthP, (!:), + (+:+), concatP, + mapP, filterP, combineP, + {- minimumP, maximumP, sumP, productP, -} -- removed until we support type classes + zipP, unzipP, zipWithP, + {- enumFromToP, enumFromThenToP, -} -- removed until we support type classes + bpermuteP, updateP, indexedP, sliceP, + crossMapP, + + -- * Conversions + fromPArrayP, toPArrayP, fromNestedPArrayP +) where + +import Data.Array.Parallel.VectDepend () -- see Note [Vectoriser dependencies] in the same module + +import Data.Array.Parallel.PArr +import Data.Array.Parallel.Prelude +import Data.Array.Parallel.Lifted +import Data.Array.Parallel.Lifted.Combinators + +import Prelude hiding (undefined) + +infixl 9 !: +infixr 5 +:+ + +undefined :: a +{-# NOINLINE undefined #-} +undefined = error "Data.Array.Parallel: undefined" +{-# VECTORISE undefined + = error "Data.Array.Parallel: undefined vectorised" + :: forall a. PA a => a #-} + +-- We only define the signatures of operations on parallel arrays (and bodies that convince GHC +-- that these functions don't just return diverge). The vectoriser rewrites them to entirely +-- the code given in the VECTORISE pragmas. + +emptyP :: [:a:] +{-# NOINLINE emptyP #-} +emptyP = emptyPArr +{-# VECTORISE emptyP = emptyPA #-} + +singletonP :: a -> [:a:] +{-# NOINLINE singletonP #-} +singletonP = singletonPArr +{-# VECTORISE singletonP = singletonPA #-} + +replicateP :: Int -> a -> [:a:] +{-# NOINLINE replicateP #-} +replicateP = replicatePArr +{-# VECTORISE replicateP = replicatePA #-} + +lengthP :: [:a:] -> Int +{-# NOINLINE lengthP #-} +lengthP = lengthPArr +{-# VECTORISE lengthP = lengthPA #-} + +(!:) :: [:a:] -> Int -> a +{-# NOINLINE (!:) #-} +(!:) = indexPArr +{-# VECTORISE (!:) = indexPA #-} + +(+:+) :: [:a:] -> [:a:] -> [:a:] +{-# NOINLINE (+:+) #-} +(+:+) xs !_ = xs +{-# VECTORISE (+:+) = appPA #-} + +concatP :: [:[:a:]:] -> [:a:] +{-# NOINLINE concatP #-} +concatP xss = xss !: 0 +{-# VECTORISE concatP = concatPA #-} + +mapP :: (a -> b) -> [:a:] -> [:b:] +{-# NOINLINE mapP #-} +mapP !_ !_ = [::] +{-# VECTORISE mapP = mapPA #-} + +filterP :: (a -> Bool) -> [:a:] -> [:a:] +{-# NOINLINE filterP #-} +filterP !_ xs = xs +{-# VECTORISE filterP = filterPA #-} + +-- sumP :: Num a => [:a:] -> a +-- {-# NOINLINE sumP #-} +-- sumP a = a !: 0 +-- -- no VECTORISE pragma as we still have the type-specific mock Prelude modules +-- +-- productP :: Num a => [:a:] -> a +-- {-# NOINLINE productP #-} +-- productP a = a !: 0 +-- +-- maximumP :: Ord a => [:a:] -> a +-- {-# NOINLINE maximumP #-} +-- maximumP a = a !: 0 +-- +-- minimumP :: Ord a => [:a:] -> a +-- {-# NOINLINE minimumP #-} +-- minimumP a = a !: 0 + +zipP :: [:a:] -> [:b:] -> [:(a, b):] +{-# NOINLINE zipP #-} +zipP !_ !_ = [::] +{-# VECTORISE zipP = zipPA #-} + +unzipP :: [:(a, b):] -> ([:a:], [:b:]) +{-# NOINLINE unzipP #-} +unzipP !_ = ([::], [::]) +{-# VECTORISE unzipP = unzipPA #-} + +zipWithP :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] +{-# NOINLINE zipWithP #-} +zipWithP !_ !_ !_ = [::] +{-# VECTORISE zipWithP = zipWithPA #-} + +-- enumFromToP :: Enum a => a -> a -> [:a:] +-- {-# NOINLINE enumFromToP #-} +-- enumFromToP x y = [:x, y:] +-- +-- enumFromThenToP :: Enum a => a -> a -> a -> [:a:] +-- {-# NOINLINE enumFromThenToP #-} +-- enumFromThenToP x y z = [:x, y, z:] + +combineP :: [:a:] -> [:a:] -> [:Int:] -> [:a:] +{-# NOINLINE combineP #-} +combineP xs !_ !_ = xs +{-# VECTORISE combineP = combine2PA #-} + +updateP :: [:a:] -> [:(Int, a):] -> [:a:] +{-# NOINLINE updateP #-} +updateP xs !_ = xs +{-# VECTORISE updateP = updatePA #-} + +bpermuteP :: [:a:] -> [:Int:] -> [:a:] +{-# NOINLINE bpermuteP #-} +bpermuteP xs !_ = xs +{-# VECTORISE bpermuteP = bpermutePA #-} + +indexedP :: [:a:] -> [:(Int, a):] +{-# NOINLINE indexedP #-} +indexedP !_ = [::] +{-# VECTORISE indexedP = indexedPA #-} + +sliceP :: Int -> Int -> [:e:] -> [:e:] +{-# NOINLINE sliceP #-} +sliceP !_ !_ xs = xs +{-# VECTORISE sliceP = slicePA #-} + +crossMapP :: [:a:] -> (a -> [:b:]) -> [:(a, b):] +{-# NOINLINE crossMapP #-} +crossMapP !_ !_ = [::] +{-# VECTORISE crossMapP = crossMapPA #-} + +fromPArrayP :: PArray a -> [:a:] +{-# NOINLINE fromPArrayP #-} +fromPArrayP !_ = emptyP +{-# VECTORISE fromPArrayP = fromPArrayPA #-} + +toPArrayP :: [:a:] -> PArray a +{-# NOINLINE toPArrayP #-} +toPArrayP !_ = PArray 0# undefined +{-# VECTORISE toPArrayP = toPArrayPA #-} + +fromNestedPArrayP :: PArray (PArray a) -> [:[:a:]:] +{-# NOINLINE fromNestedPArrayP #-} +fromNestedPArrayP !_ = emptyP +{-# VECTORISE fromNestedPArrayP = fromNestedPArrayPA #-} + +{- ================================================================================================ + This is the old code from GHC.PArr that we used to implement parallel arrays without + vectorisation. As soon as partial vectorisation has been implemented, we should revise + this code to support the mixed use of vectorised and non-vectorised code with parallel + arrays. This will probably require the use of a different representation of parallel arrays + that is a sum of the flattened and an unflattened representation. + +{-# LANGUAGE MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module GHC.PArr ( + -- [::], -- Built-in syntax + + mapP, -- :: (a -> b) -> [:a:] -> [:b:] + (+:+), -- :: [:a:] -> [:a:] -> [:a:] + filterP, -- :: (a -> Bool) -> [:a:] -> [:a:] + concatP, -- :: [:[:a:]:] -> [:a:] + concatMapP, -- :: (a -> [:b:]) -> [:a:] -> [:b:] +-- head, last, tail, init, -- it's not wise to use them on arrays + nullP, -- :: [:a:] -> Bool + lengthP, -- :: [:a:] -> Int + (!:), -- :: [:a:] -> Int -> a + foldlP, -- :: (a -> b -> a) -> a -> [:b:] -> a + foldl1P, -- :: (a -> a -> a) -> [:a:] -> a + scanlP, -- :: (a -> b -> a) -> a -> [:b:] -> [:a:] + scanl1P, -- :: (a -> a -> a) -> [:a:] -> [:a:] + foldrP, -- :: (a -> b -> b) -> b -> [:a:] -> b + foldr1P, -- :: (a -> a -> a) -> [:a:] -> a + scanrP, -- :: (a -> b -> b) -> b -> [:a:] -> [:b:] + scanr1P, -- :: (a -> a -> a) -> [:a:] -> [:a:] +-- iterate, repeat, -- parallel arrays must be finite + singletonP, -- :: a -> [:a:] + emptyP, -- :: [:a:] + replicateP, -- :: Int -> a -> [:a:] +-- cycle, -- parallel arrays must be finite + takeP, -- :: Int -> [:a:] -> [:a:] + dropP, -- :: Int -> [:a:] -> [:a:] + splitAtP, -- :: Int -> [:a:] -> ([:a:],[:a:]) + takeWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:] + dropWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:] + spanP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) + breakP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) +-- lines, words, unlines, unwords, -- is string processing really needed + reverseP, -- :: [:a:] -> [:a:] + andP, -- :: [:Bool:] -> Bool + orP, -- :: [:Bool:] -> Bool + anyP, -- :: (a -> Bool) -> [:a:] -> Bool + allP, -- :: (a -> Bool) -> [:a:] -> Bool + elemP, -- :: (Eq a) => a -> [:a:] -> Bool + notElemP, -- :: (Eq a) => a -> [:a:] -> Bool + lookupP, -- :: (Eq a) => a -> [:(a, b):] -> Maybe b + sumP, -- :: (Num a) => [:a:] -> a + productP, -- :: (Num a) => [:a:] -> a + maximumP, -- :: (Ord a) => [:a:] -> a + minimumP, -- :: (Ord a) => [:a:] -> a + zipP, -- :: [:a:] -> [:b:] -> [:(a, b) :] + zip3P, -- :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] + zipWithP, -- :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] + zipWith3P, -- :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:] + unzipP, -- :: [:(a, b) :] -> ([:a:], [:b:]) + unzip3P, -- :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) + + -- overloaded functions + -- + enumFromToP, -- :: Enum a => a -> a -> [:a:] + enumFromThenToP, -- :: Enum a => a -> a -> a -> [:a:] + + -- the following functions are not available on lists + -- + toP, -- :: [a] -> [:a:] + fromP, -- :: [:a:] -> [a] + sliceP, -- :: Int -> Int -> [:e:] -> [:e:] + foldP, -- :: (e -> e -> e) -> e -> [:e:] -> e + fold1P, -- :: (e -> e -> e) -> [:e:] -> e + permuteP, -- :: [:Int:] -> [:e:] -> [:e:] + bpermuteP, -- :: [:Int:] -> [:e:] -> [:e:] + dpermuteP, -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:] + crossP, -- :: [:a:] -> [:b:] -> [:(a, b):] + crossMapP, -- :: [:a:] -> (a -> [:b:]) -> [:(a, b):] + indexOfP -- :: (a -> Bool) -> [:a:] -> [:Int:] +) where + +#ifndef __HADDOCK__ + +import Prelude + +import GHC.ST ( ST(..), runST ) +import GHC.Base ( Int#, Array#, Int(I#), MutableArray#, newArray#, + unsafeFreezeArray#, indexArray#, writeArray#, (<#), (>=#) ) + +infixl 9 !: +infixr 5 +:+ +infix 4 `elemP`, `notElemP` + + +-- representation of parallel arrays +-- --------------------------------- + +-- this rather straight forward implementation maps parallel arrays to the +-- internal representation used for standard Haskell arrays in GHC's Prelude +-- (EXPORTED ABSTRACTLY) +-- +-- * This definition *must* be kept in sync with `TysWiredIn.parrTyCon'! +-- +data [::] e = PArr Int# (Array# e) + + +-- exported operations on parallel arrays +-- -------------------------------------- + +-- operations corresponding to list operations +-- + +mapP :: (a -> b) -> [:a:] -> [:b:] +mapP f = fst . loop (mapEFL f) noAL + +(+:+) :: [:a:] -> [:a:] -> [:a:] +a1 +:+ a2 = fst $ loop (mapEFL sel) noAL (enumFromToP 0 (len1 + len2 - 1)) + -- we can't use the [:x..y:] form here for tedious + -- reasons to do with the typechecker and the fact that + -- `enumFromToP' is defined in the same module + where + len1 = lengthP a1 + len2 = lengthP a2 + -- + sel i | i < len1 = a1!:i + | otherwise = a2!:(i - len1) + +filterP :: (a -> Bool) -> [:a:] -> [:a:] +filterP p = fst . loop (filterEFL p) noAL + +concatP :: [:[:a:]:] -> [:a:] +concatP xss = foldlP (+:+) [::] xss + +concatMapP :: (a -> [:b:]) -> [:a:] -> [:b:] +concatMapP f = concatP . mapP f + +-- head, last, tail, init, -- it's not wise to use them on arrays + +nullP :: [:a:] -> Bool +nullP [::] = True +nullP _ = False + +lengthP :: [:a:] -> Int +lengthP (PArr n# _) = I# n# + +(!:) :: [:a:] -> Int -> a +(!:) = indexPArr + +foldlP :: (a -> b -> a) -> a -> [:b:] -> a +foldlP f z = snd . loop (foldEFL (flip f)) z + +foldl1P :: (a -> a -> a) -> [:a:] -> a +foldl1P _ [::] = error "Prelude.foldl1P: empty array" +foldl1P f a = snd $ loopFromTo 1 (lengthP a - 1) (foldEFL f) (a!:0) a + +scanlP :: (a -> b -> a) -> a -> [:b:] -> [:a:] +scanlP f z = fst . loop (scanEFL (flip f)) z + +scanl1P :: (a -> a -> a) -> [:a:] -> [:a:] +scanl1P _ [::] = error "Prelude.scanl1P: empty array" +scanl1P f a = fst $ loopFromTo 1 (lengthP a - 1) (scanEFL f) (a!:0) a + +foldrP :: (a -> b -> b) -> b -> [:a:] -> b +foldrP = error "Prelude.foldrP: not implemented yet" -- FIXME + +foldr1P :: (a -> a -> a) -> [:a:] -> a +foldr1P = error "Prelude.foldr1P: not implemented yet" -- FIXME + +scanrP :: (a -> b -> b) -> b -> [:a:] -> [:b:] +scanrP = error "Prelude.scanrP: not implemented yet" -- FIXME + +scanr1P :: (a -> a -> a) -> [:a:] -> [:a:] +scanr1P = error "Prelude.scanr1P: not implemented yet" -- FIXME + +-- iterate, repeat -- parallel arrays must be finite + +singletonP :: a -> [:a:] +{-# INLINE singletonP #-} +singletonP e = replicateP 1 e + +emptyP:: [:a:] +{- NOINLINE emptyP #-} +emptyP = replicateP 0 undefined + + +replicateP :: Int -> a -> [:a:] +{-# INLINE replicateP #-} +replicateP n e = runST (do + marr# <- newArray n e + mkPArr n marr#) + +-- cycle -- parallel arrays must be finite + +takeP :: Int -> [:a:] -> [:a:] +takeP n = sliceP 0 (n - 1) + +dropP :: Int -> [:a:] -> [:a:] +dropP n a = sliceP n (lengthP a - 1) a + +splitAtP :: Int -> [:a:] -> ([:a:],[:a:]) +splitAtP n xs = (takeP n xs, dropP n xs) + +takeWhileP :: (a -> Bool) -> [:a:] -> [:a:] +takeWhileP = error "Prelude.takeWhileP: not implemented yet" -- FIXME + +dropWhileP :: (a -> Bool) -> [:a:] -> [:a:] +dropWhileP = error "Prelude.dropWhileP: not implemented yet" -- FIXME + +spanP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) +spanP = error "Prelude.spanP: not implemented yet" -- FIXME + +breakP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) +breakP p = spanP (not . p) + +-- lines, words, unlines, unwords, -- is string processing really needed + +reverseP :: [:a:] -> [:a:] +reverseP a = permuteP (enumFromThenToP (len - 1) (len - 2) 0) a + -- we can't use the [:x, y..z:] form here for tedious + -- reasons to do with the typechecker and the fact that + -- `enumFromThenToP' is defined in the same module + where + len = lengthP a + +andP :: [:Bool:] -> Bool +andP = foldP (&&) True + +orP :: [:Bool:] -> Bool +orP = foldP (||) True + +anyP :: (a -> Bool) -> [:a:] -> Bool +anyP p = orP . mapP p + +allP :: (a -> Bool) -> [:a:] -> Bool +allP p = andP . mapP p + +elemP :: (Eq a) => a -> [:a:] -> Bool +elemP x = anyP (== x) + +notElemP :: (Eq a) => a -> [:a:] -> Bool +notElemP x = allP (/= x) + +lookupP :: (Eq a) => a -> [:(a, b):] -> Maybe b +lookupP = error "Prelude.lookupP: not implemented yet" -- FIXME + +sumP :: (Num a) => [:a:] -> a +sumP = foldP (+) 0 + +productP :: (Num a) => [:a:] -> a +productP = foldP (*) 1 + +maximumP :: (Ord a) => [:a:] -> a +maximumP [::] = error "Prelude.maximumP: empty parallel array" +maximumP xs = fold1P max xs + +minimumP :: (Ord a) => [:a:] -> a +minimumP [::] = error "Prelude.minimumP: empty parallel array" +minimumP xs = fold1P min xs + +zipP :: [:a:] -> [:b:] -> [:(a, b):] +zipP = zipWithP (,) + +zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] +zip3P = zipWith3P (,,) + +zipWithP :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] +zipWithP f a1 a2 = let + len1 = lengthP a1 + len2 = lengthP a2 + len = len1 `min` len2 + in + fst $ loopFromTo 0 (len - 1) combine 0 a1 + where + combine e1 i = (Just $ f e1 (a2!:i), i + 1) + +zipWith3P :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:] +zipWith3P f a1 a2 a3 = let + len1 = lengthP a1 + len2 = lengthP a2 + len3 = lengthP a3 + len = len1 `min` len2 `min` len3 + in + fst $ loopFromTo 0 (len - 1) combine 0 a1 + where + combine e1 i = (Just $ f e1 (a2!:i) (a3!:i), i + 1) + +unzipP :: [:(a, b):] -> ([:a:], [:b:]) +unzipP a = (fst $ loop (mapEFL fst) noAL a, fst $ loop (mapEFL snd) noAL a) +-- FIXME: these two functions should be optimised using a tupled custom loop +unzip3P :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) +unzip3P x = (fst $ loop (mapEFL fst3) noAL x, + fst $ loop (mapEFL snd3) noAL x, + fst $ loop (mapEFL trd3) noAL x) + where + fst3 (a, _, _) = a + snd3 (_, b, _) = b + trd3 (_, _, c) = c + +-- instances +-- + +instance Eq a => Eq [:a:] where + a1 == a2 | lengthP a1 == lengthP a2 = andP (zipWithP (==) a1 a2) + | otherwise = False + +instance Ord a => Ord [:a:] where + compare a1 a2 = case foldlP combineOrdering EQ (zipWithP compare a1 a2) of + EQ | lengthP a1 == lengthP a2 -> EQ + | lengthP a1 < lengthP a2 -> LT + | otherwise -> GT + where + combineOrdering EQ EQ = EQ + combineOrdering EQ other = other + combineOrdering other _ = other + +instance Functor [::] where + fmap = mapP + +instance Monad [::] where + m >>= k = foldrP ((+:+) . k ) [::] m + m >> k = foldrP ((+:+) . const k) [::] m + return x = [:x:] + fail _ = [::] + +instance Show a => Show [:a:] where + showsPrec _ = showPArr . fromP + where + showPArr [] s = "[::]" ++ s + showPArr (x:xs) s = "[:" ++ shows x (showPArr' xs s) + + showPArr' [] s = ":]" ++ s + showPArr' (y:ys) s = ',' : shows y (showPArr' ys s) + +instance Read a => Read [:a:] where + readsPrec _ a = [(toP v, rest) | (v, rest) <- readPArr a] + where + readPArr = readParen False (\r -> do + ("[:",s) <- lex r + readPArr1 s) + readPArr1 s = + (do { (":]", t) <- lex s; return ([], t) }) ++ + (do { (x, t) <- reads s; (xs, u) <- readPArr2 t; return (x:xs, u) }) + + readPArr2 s = + (do { (":]", t) <- lex s; return ([], t) }) ++ + (do { (",", t) <- lex s; (x, u) <- reads t; (xs, v) <- readPArr2 u; + return (x:xs, v) }) + +-- overloaded functions +-- + +-- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of +-- `Enum'. On the other hand, we really do not want to change `Enum'. Thus, +-- for the moment, we hope that the compiler is sufficiently clever to +-- properly fuse the following definitions. + +enumFromToP :: Enum a => a -> a -> [:a:] +enumFromToP x0 y0 = mapP toEnum (eftInt (fromEnum x0) (fromEnum y0)) + where + eftInt x y = scanlP (+) x $ replicateP (y - x + 1) 1 + +enumFromThenToP :: Enum a => a -> a -> a -> [:a:] +enumFromThenToP x0 y0 z0 = + mapP toEnum (efttInt (fromEnum x0) (fromEnum y0) (fromEnum z0)) + where + efttInt x y z = scanlP (+) x $ + replicateP (abs (z - x) `div` abs delta + 1) delta + where + delta = y - x + +-- the following functions are not available on lists +-- + +-- create an array from a list (EXPORTED) +-- +toP :: [a] -> [:a:] +toP l = fst $ loop store l (replicateP (length l) ()) + where + store _ (x:xs) = (Just x, xs) + +-- convert an array to a list (EXPORTED) +-- +fromP :: [:a:] -> [a] +fromP a = [a!:i | i <- [0..lengthP a - 1]] + +-- cut a subarray out of an array (EXPORTED) +-- +sliceP :: Int -> Int -> [:e:] -> [:e:] +sliceP from to a = + fst $ loopFromTo (0 `max` from) (to `min` (lengthP a - 1)) (mapEFL id) noAL a + +-- parallel folding (EXPORTED) +-- +-- * the first argument must be associative; otherwise, the result is undefined +-- +foldP :: (e -> e -> e) -> e -> [:e:] -> e +foldP = foldlP + +-- parallel folding without explicit neutral (EXPORTED) +-- +-- * the first argument must be associative; otherwise, the result is undefined +-- +fold1P :: (e -> e -> e) -> [:e:] -> e +fold1P = foldl1P + +-- permute an array according to the permutation vector in the first argument +-- (EXPORTED) +-- +permuteP :: [:Int:] -> [:e:] -> [:e:] +permuteP is es + | isLen /= esLen = error "GHC.PArr: arguments must be of the same length" + | otherwise = runST (do + marr <- newArray isLen noElem + permute marr is es + mkPArr isLen marr) + where + noElem = error "GHC.PArr.permuteP: I do not exist!" + -- unlike standard Haskell arrays, this value represents an + -- internal error + isLen = lengthP is + esLen = lengthP es + +-- permute an array according to the back-permutation vector in the first +-- argument (EXPORTED) +-- +-- * the permutation vector must represent a surjective function; otherwise, +-- the result is undefined +-- +bpermuteP :: [:Int:] -> [:e:] -> [:e:] +bpermuteP is es = fst $ loop (mapEFL (es!:)) noAL is + +-- permute an array according to the permutation vector in the first +-- argument, which need not be surjective (EXPORTED) +-- +-- * any elements in the result that are not covered by the permutation +-- vector assume the value of the corresponding position of the third +-- argument +-- +dpermuteP :: [:Int:] -> [:e:] -> [:e:] -> [:e:] +dpermuteP is es dft + | isLen /= esLen = error "GHC.PArr: arguments must be of the same length" + | otherwise = runST (do + marr <- newArray dftLen noElem + _ <- trans 0 (isLen - 1) marr dft copyOne noAL + permute marr is es + mkPArr dftLen marr) + where + noElem = error "GHC.PArr.permuteP: I do not exist!" + -- unlike standard Haskell arrays, this value represents an + -- internal error + isLen = lengthP is + esLen = lengthP es + dftLen = lengthP dft + + copyOne e _ = (Just e, noAL) + +-- computes the cross combination of two arrays (EXPORTED) +-- +crossP :: [:a:] -> [:b:] -> [:(a, b):] +crossP a1 a2 = fst $ loop combine (0, 0) $ replicateP len () + where + len1 = lengthP a1 + len2 = lengthP a2 + len = len1 * len2 + -- + combine _ (i, j) = (Just $ (a1!:i, a2!:j), next) + where + next | (i + 1) == len1 = (0 , j + 1) + | otherwise = (i + 1, j) + +{- An alternative implementation + * The one above is certainly better for flattened code, but here where we + are handling boxed arrays, the trade off is less clear. However, I + think, the above one is still better. + +crossP a1 a2 = let + len1 = lengthP a1 + len2 = lengthP a2 + x1 = concatP $ mapP (replicateP len2) a1 + x2 = concatP $ replicateP len1 a2 + in + zipP x1 x2 + -} + +-- |Compute a cross of an array and the arrays produced by the given function +-- for the elements of the first array. +-- +crossMapP :: [:a:] -> (a -> [:b:]) -> [:(a, b):] +crossMapP a f = let + bs = mapP f a + segd = mapP lengthP bs + as = zipWithP replicateP segd a + in + zipP (concatP as) (concatP bs) + +{- The following may seem more straight forward, but the above is very cheap + with segmented arrays, as `mapP lengthP', `zipP', and `concatP' are + constant time, and `map f' uses the lifted version of `f'. + +crossMapP a f = concatP $ mapP (\x -> mapP ((,) x) (f x)) a + + -} + +-- computes an index array for all elements of the second argument for which +-- the predicate yields `True' (EXPORTED) +-- +indexOfP :: (a -> Bool) -> [:a:] -> [:Int:] +indexOfP p a = fst $ loop calcIdx 0 a + where + calcIdx e idx | p e = (Just idx, idx + 1) + | otherwise = (Nothing , idx ) + + +-- auxiliary functions +-- ------------------- + +-- internally used mutable boxed arrays +-- +data MPArr s e = MPArr Int# (MutableArray# s e) + +-- allocate a new mutable array that is pre-initialised with a given value +-- +newArray :: Int -> e -> ST s (MPArr s e) +{-# INLINE newArray #-} +newArray (I# n#) e = ST $ \s1# -> + case newArray# n# e s1# of { (# s2#, marr# #) -> + (# s2#, MPArr n# marr# #)} + +-- convert a mutable array into the external parallel array representation +-- +mkPArr :: Int -> MPArr s e -> ST s [:e:] +{-# INLINE mkPArr #-} +mkPArr (I# n#) (MPArr _ marr#) = ST $ \s1# -> + case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> + (# s2#, PArr n# arr# #) } + +-- general array iterator +-- +-- * corresponds to `loopA' from ``Functional Array Fusion'', Chakravarty & +-- Keller, ICFP 2001 +-- +loop :: (e -> acc -> (Maybe e', acc)) -- mapping & folding, once per element + -> acc -- initial acc value + -> [:e:] -- input array + -> ([:e':], acc) +{-# INLINE loop #-} +loop mf acc arr = loopFromTo 0 (lengthP arr - 1) mf acc arr + +-- general array iterator with bounds +-- +loopFromTo :: Int -- from index + -> Int -- to index + -> (e -> acc -> (Maybe e', acc)) + -> acc + -> [:e:] + -> ([:e':], acc) +{-# INLINE loopFromTo #-} +loopFromTo from to mf start arr = runST (do + marr <- newArray (to - from + 1) noElem + (n', acc) <- trans from to marr arr mf start + arr' <- mkPArr n' marr + return (arr', acc)) + where + noElem = error "GHC.PArr.loopFromTo: I do not exist!" + -- unlike standard Haskell arrays, this value represents an + -- internal error + +-- actual loop body of `loop' +-- +-- * for this to be really efficient, it has to be translated with the +-- constructor specialisation phase "SpecConstr" switched on; as of GHC 5.03 +-- this requires an optimisation level of at least -O2 +-- +trans :: Int -- index of first elem to process + -> Int -- index of last elem to process + -> MPArr s e' -- destination array + -> [:e:] -- source array + -> (e -> acc -> (Maybe e', acc)) -- mutator + -> acc -- initial accumulator + -> ST s (Int, acc) -- final destination length/final acc +{-# INLINE trans #-} +trans from to marr arr mf start = trans' from 0 start + where + trans' arrOff marrOff acc + | arrOff > to = return (marrOff, acc) + | otherwise = do + let (oe', acc') = mf (arr `indexPArr` arrOff) acc + marrOff' <- case oe' of + Nothing -> return marrOff + Just e' -> do + writeMPArr marr marrOff e' + return $ marrOff + 1 + trans' (arrOff + 1) marrOff' acc' + +-- Permute the given elements into the mutable array. +-- +permute :: MPArr s e -> [:Int:] -> [:e:] -> ST s () +permute marr is es = perm 0 + where + perm i + | i == n = return () + | otherwise = writeMPArr marr (is!:i) (es!:i) >> perm (i + 1) + where + n = lengthP is + + +-- common patterns for using `loop' +-- + +-- initial value for the accumulator when the accumulator is not needed +-- +noAL :: () +noAL = () + +-- `loop' mutator maps a function over array elements +-- +mapEFL :: (e -> e') -> (e -> () -> (Maybe e', ())) +{-# INLINE mapEFL #-} +mapEFL f = \e _ -> (Just $ f e, ()) + +-- `loop' mutator that filter elements according to a predicate +-- +filterEFL :: (e -> Bool) -> (e -> () -> (Maybe e, ())) +{-# INLINE filterEFL #-} +filterEFL p = \e _ -> if p e then (Just e, ()) else (Nothing, ()) + +-- `loop' mutator for array folding +-- +foldEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe (), acc)) +{-# INLINE foldEFL #-} +foldEFL f = \e a -> (Nothing, f e a) + +-- `loop' mutator for array scanning +-- +scanEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe acc, acc)) +{-# INLINE scanEFL #-} +scanEFL f = \e a -> (Just a, f e a) + +-- elementary array operations +-- + +-- unlifted array indexing +-- +indexPArr :: [:e:] -> Int -> e +{-# INLINE indexPArr #-} +indexPArr (PArr n# arr#) (I# i#) + | i# >=# 0# && i# <# n# = + case indexArray# arr# i# of (# e #) -> e + | otherwise = error $ "indexPArr: out of bounds parallel array index; " ++ + "idx = " ++ show (I# i#) ++ ", arr len = " + ++ show (I# n#) + +-- encapsulate writing into a mutable array into the `ST' monad +-- +writeMPArr :: MPArr s e -> Int -> e -> ST s () +{-# INLINE writeMPArr #-} +writeMPArr (MPArr n# marr#) (I# i#) e + | i# >=# 0# && i# <# n# = + ST $ \s# -> + case writeArray# marr# i# e s# of s'# -> (# s'#, () #) + | otherwise = error $ "writeMPArr: out of bounds parallel array index; " ++ + "idx = " ++ show (I# i#) ++ ", arr len = " + ++ show (I# n#) + +-} diff --git a/Data/Array/Parallel/Lifted.hs b/Data/Array/Parallel/Lifted.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Lifted.hs @@ -0,0 +1,25 @@ +module Data.Array.Parallel.Lifted ( + module Data.Array.Parallel.Lifted.PArray, + module Data.Array.Parallel.PArray.PReprInstances, + + (:->), ($:), ($:^), + + fromPArrayPA, toPArrayPA, fromNestedPArrayPA, +) where + +import Data.Array.Parallel.Lifted.PArray +import Data.Array.Parallel.Lifted.Closure +import Data.Array.Parallel.PArray.PReprInstances + +fromPArrayPA :: PA a => PArray a :-> PArray a +{-# INLINE fromPArrayPA #-} +fromPArrayPA = closure1 (\x -> x) (\xs -> xs) + +toPArrayPA :: PA a => PArray a :-> PArray a +{-# INLINE toPArrayPA #-} +toPArrayPA = closure1 (\x -> x) (\xs -> xs) + +fromNestedPArrayPA :: PA a => (PArray (PArray a) :-> PArray (PArray a)) +{-# INLINE fromNestedPArrayPA #-} +fromNestedPArrayPA = closure1 (\xs -> xs) (\xss -> xss) + diff --git a/Data/Array/Parallel/Lifted/Closure.hs b/Data/Array/Parallel/Lifted/Closure.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Lifted/Closure.hs @@ -0,0 +1,226 @@ +{-# OPTIONS -fno-warn-missing-methods #-} +module Data.Array.Parallel.Lifted.Closure ( + (:->)(..), PArray(..), + mkClosure, mkClosureP, ($:), ($:^), + closure, liftedClosure, liftedApply, + + closure1, closure2, closure3 +) where +import Data.Array.Parallel.PArray.PReprInstances () +import Data.Array.Parallel.PArray.PDataInstances +import Data.Array.Parallel.Lifted.PArray + +import GHC.Exts (Int#) + +infixr 0 :-> +infixl 0 $:, $:^ + +-- | The type of closures. +-- This bundles up: +-- 1) the vectorised version of the function that takes an explicit environment +-- 2) the lifted version, that works on arrays. +-- the first parameter of this function is the 'lifting context' +-- that gives the length of the array. +-- 3) the environment of the closure. +-- +-- The vectoriser closure-converts the source program so that all functions +-- types are expressed in this form. +-- +data a :-> b + = forall e. PA e + => Clo !(e -> a -> b) -- vectorised function + !(Int# -> PData e -> PData a -> PData b) -- lifted function + e -- environment + + +-- | Apply a lifted function by wrapping up the provided array data +-- into some real `PArray`s, and passing it those. +lifted :: (PArray e -> PArray a -> PArray b) -- ^ lifted function to call. + -> Int# -- ^ lifting context + -> PData e -- ^ environments + -> PData a -- ^ arguments + -> PData b -- ^ returned elements +{-# INLINE lifted #-} +lifted f n# es as + = case f (PArray n# es) (PArray n# as) of + PArray _ bs -> bs + + +-- | Construct a closure. +mkClosure + :: forall a b e + . PA e + => (e -> a -> b) -- ^ vectorised function, with explicit environment. + -> (PArray e -> PArray a -> PArray b) -- ^ lifted function, taking an array of environments. + -> e -- ^ environment + -> (a :-> b) +{-# INLINE CONLIKE mkClosure #-} +mkClosure fv fl e + = Clo fv (lifted fl) e + + +-- | Construct a closure. +-- This is like the `mkClosure` function above, except that the provided +-- lifted version of the function can take raw array data, instead of +-- data wrapped up into a `PArray`. +closure :: forall a b e + . PA e + => (e -> a -> b) -- ^ vectorised function, with explicit environment. + -> (Int# -> PData e -> PData a -> PData b) -- ^ lifted function, taking an array of environments. + -> e -- ^ environment + -> (a :-> b) +{-# INLINE closure #-} +closure fv fl e = Clo fv fl e + + +-- | Apply a closure to its argument. +-- +($:) :: forall a b. (a :-> b) -> a -> b +{-# INLINE ($:) #-} +Clo f _ e $: a = f e a + +{-# RULES + +"mkClosure/($:)" forall fv fl e x. + mkClosure fv fl e $: x = fv e x + + #-} + + +-- | Arrays of closures (aka array closures) +-- We need to represent arrays of closures when vectorising partial applications. +-- +-- For example, consider: +-- @mapP (+) xs :: [: Int -> Int :]@ +-- +-- Representing this an array of thunks doesn't work because we can't evaluate +-- in a data parallel manner. Instead, we want *one* function applied to many +-- array elements. +-- +-- Instead, such an array of closures is represented as the vectorised +-- and lifted versions of (+), along with an environment array xs that +-- contains the partially applied arguments. +-- +-- @mapP (+) xs ==> AClo plus_v plus_l xs@ +-- +-- When we find out what the final argument is, we can then use the lifted +-- closure application function to compute the result: +-- +-- @PArray n (AClo plus_v plus_l xs) $:^ (PArray n' ys) +-- => PArray n (plus_l n xs ys)@ +-- +data instance PData (a :-> b) + = forall e. PA e + => AClo !(e -> a -> b) -- vectorised function, with explicit environment. + !(Int# -> PData e -> PData a -> PData b) -- lifted function, taking an array of environments. + (PData e) -- array of environments. + + +-- |Lifted closure construction +-- +mkClosureP :: forall a b e. + PA e => (e -> a -> b) + -> (PArray e -> PArray a -> PArray b) + -> PArray e -> PArray (a :-> b) +{-# INLINE mkClosureP #-} +mkClosureP fv fl (PArray n# es) + = PArray n# (AClo fv (lifted fl) es) + + +liftedClosure :: forall a b e. + PA e => (e -> a -> b) + -> (Int# -> PData e -> PData a -> PData b) + -> PData e + -> PData (a :-> b) +{-# INLINE liftedClosure #-} +liftedClosure fv fl es = AClo fv fl es + + +-- |Lifted closure application +-- +($:^) :: forall a b. PArray (a :-> b) -> PArray a -> PArray b +{-# INLINE ($:^) #-} +PArray n# (AClo _ f es) $:^ PArray _ as + = PArray n# (f n# es as) + + +liftedApply :: forall a b. Int# -> PData (a :-> b) -> PData a -> PData b +{-# INLINE liftedApply #-} +liftedApply n# (AClo _ f es) as + = f n# es as + + +-- PRepr instance for closures ------------------------------------------------ +type instance PRepr (a :-> b) = a :-> b + +instance (PA a, PA b) => PA (a :-> b) where + toPRepr = id + fromPRepr = id + toArrPRepr = id + fromArrPRepr = id + +instance PR (a :-> b) where + {-# INLINE emptyPR #-} + emptyPR = AClo (\_ _ -> error "empty array closure") + (\_ _ -> error "empty array closure") + (emptyPD :: PData ()) + + {-# INLINE replicatePR #-} + replicatePR n# (Clo f f' e) + = AClo f f' (replicatePD n# e) + + {-# INLINE replicatelPR #-} + replicatelPR segd (AClo f f' es) + = AClo f f' (replicatelPD segd es) + + {-# INLINE indexPR #-} + indexPR (AClo f f' es) i# + = Clo f f' (indexPD es i#) + + {-# INLINE bpermutePR #-} + bpermutePR (AClo f f' es) n# is + = AClo f f' (bpermutePD es n# is) + + {-# INLINE packByTagPR #-} + packByTagPR (AClo f f' es) n# tags t# + = AClo f f' (packByTagPD es n# tags t#) + + +-- Closure construction ------------------------------------------------------- +-- | Arity-1 closures. +closure1 :: (a -> b) -> (PArray a -> PArray b) -> (a :-> b) +{-# INLINE closure1 #-} +closure1 fv fl = mkClosure (\_ -> fv) (\_ -> fl) () + + +-- | Arity-2 closures. +closure2 :: PA a + => (a -> b -> c) + -> (PArray a -> PArray b -> PArray c) + -> (a :-> b :-> c) + +{-# INLINE closure2 #-} +closure2 fv fl = mkClosure fv_1 fl_1 () + where + fv_1 _ x = mkClosure fv fl x + fl_1 _ xs = mkClosureP fv fl xs + + +-- | Arity-3 closures. +closure3 :: (PA a, PA b) + => (a -> b -> c -> d) + -> (PArray a -> PArray b -> PArray c -> PArray d) + -> (a :-> b :-> c :-> d) + +{-# INLINE closure3 #-} +closure3 fv fl = mkClosure fv_1 fl_1 () + where + fv_1 _ x = mkClosure fv_2 fl_2 x + fl_1 _ xs = mkClosureP fv_2 fl_2 xs + + fv_2 x y = mkClosure fv_3 fl_3 (x,y) + fl_2 xs ys = mkClosureP fv_3 fl_3 (zipPA# xs ys) + + fv_3 (x,y) z = fv x y z + fl_3 ps zs = case unzipPA# ps of (xs,ys) -> fl xs ys zs + diff --git a/Data/Array/Parallel/Lifted/Combinators.hs b/Data/Array/Parallel/Lifted/Combinators.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Lifted/Combinators.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +#include "fusion-phases.h" + +-- | Define the closures for the array combinators the vectoriser uses. +-- The closures themselves use the *PD primitives defined in +-- dph-common:Data.Array.Parallel.Lifted.Combinators +-- +-- For each combinator: +-- The *PA_v version is the "vectorised" version that has had its +-- parameters closure converted. See zipWithPA_v for an example. +-- +-- The *PA_l version is the "lifted" version that also works +-- on arrays of arrays. +-- +-- The *PA version contains both of these wrapped up into a closure. +-- The output of the vectoriser uses these *PA versions directly, +-- with applications being performed by the liftedApply function +-- from "Data.Array.Parallel.Lifted.Closure" +-- +-- TODO: combine2PA_l isn't implemented and will just `error` if you +-- try to use it. None of our benchmarks do yet... +-- +module Data.Array.Parallel.Lifted.Combinators ( + lengthPA, replicatePA, singletonPA, mapPA, crossMapPA, + zipWithPA, zipPA, unzipPA, + packPA, filterPA, combine2PA, indexPA, concatPA, appPA, enumFromToPA_Int, + indexedPA, slicePA, updatePA, bpermutePA, + + -- * Functions re-exported by Data.Array.Parallel.PArray + lengthPA_v, replicatePA_v, singletonPA_v, zipPA_v, unzipPA_v, + packPA_v, concatPA_v, indexedPA_v, updatePA_v, bpermutePA_v, + slicePA_v, indexPA_v, appPA_v, enumFromToPA_v +) where +import Data.Array.Parallel.Lifted.PArray +import Data.Array.Parallel.Lifted.Closure +import Data.Array.Parallel.Lifted.Unboxed +import Data.Array.Parallel.Lifted.Scalar +import Data.Array.Parallel.PArray.PReprInstances +import Data.Array.Parallel.PArray.PDataInstances +import Data.Array.Parallel.PArray.ScalarInstances + +import qualified Data.Array.Parallel.Unlifted as U +import Data.Array.Parallel.Base (Tag) + +import GHC.Exts (Int(..), (+#)) + + +-- length --------------------------------------------------------------------- +-- | Take the number of elements in an array. +lengthPA :: PA a => PArray a :-> Int +{-# INLINE lengthPA #-} +lengthPA = closure1 lengthPA_v lengthPA_l + +lengthPA_v :: PA a => PArray a -> Int +{-# INLINE_PA lengthPA_v #-} +lengthPA_v xs = I# (lengthPA# xs) + +lengthPA_l :: PA a => PArray (PArray a) -> PArray Int +{-# INLINE_PA lengthPA_l #-} +lengthPA_l xss = fromUArrPA (U.elementsSegd segd) (U.lengthsSegd segd) + where + segd = segdPA# xss + + +-- replicate ------------------------------------------------------------------ +-- | Produce a new array by replicating a single element the given number of times. +replicatePA :: PA a => Int :-> a :-> PArray a +{-# INLINE replicatePA #-} +replicatePA = closure2 replicatePA_v replicatePA_l + +replicatePA_v :: PA a => Int -> a -> PArray a +{-# INLINE_PA replicatePA_v #-} +replicatePA_v (I# n#) x = replicatePA# n# x + +replicatePA_l :: PA a => PArray Int -> PArray a -> PArray (PArray a) +{-# INLINE_PA replicatePA_l #-} +replicatePA_l (PArray n# (PInt ns)) (PArray _ xs) + = PArray n# (PNested segd (replicatelPD segd xs)) + where + segd = U.lengthsToSegd ns + + +-- singleton ------------------------------------------------------------------ +-- | Produce an array containing a single element. +singletonPA :: PA a => a :-> PArray a +{-# INLINE singletonPA #-} +singletonPA = closure1 singletonPA_v singletonPA_l + +singletonPA_v :: PA a => a -> PArray a +{-# INLINE_PA singletonPA_v #-} +singletonPA_v x = replicatePA_v 1 x + +singletonPA_l :: PA a => PArray a -> PArray (PArray a) +{-# INLINE_PA singletonPA_l #-} +singletonPA_l (PArray n# xs) + = PArray n# (PNested (U.mkSegd (U.replicate (I# n#) 1) + (U.enumFromStepLen 0 1 (I# n#)) + (I# n#)) + xs) + + +-- map ------------------------------------------------------------------------ +-- | Apply a worker function to each element of an array, yielding a new array. +mapPA :: (PA a, PA b) => (a :-> b) :-> PArray a :-> PArray b +{-# INLINE mapPA #-} +mapPA = closure2 mapPA_v mapPA_l + +-- | When performing a map we `replicate` the function into an array, then use +-- lifted-application to apply each function to its corresponding argument. +-- +-- Note that this is a virtual replicate only, meaning that we can use +-- the same vectorised and lifted worker functions, provided we replicate +-- the environment part of the closure. The instance for repliatePA# in +-- PRepr class does exactly this, and it's defined in +-- "Data.Array.Parallel.Lifted.Closure". +-- +mapPA_v :: (PA a, PA b) => (a :-> b) -> PArray a -> PArray b +{-# INLINE_PA mapPA_v #-} +mapPA_v f as = replicatePA# (lengthPA# as) f $:^ as + +mapPA_l :: (PA a, PA b) + => PArray (a :-> b) -> PArray (PArray a) -> PArray (PArray b) +{-# INLINE_PA mapPA_l #-} +mapPA_l (PArray n# clo) (PArray _ xss) + = PArray n# + $ case xss of { PNested segd xs -> + PNested segd + $ liftedApply (case U.elementsSegd segd of { I# k# -> k# }) + (replicatelPD segd clo) + xs } + + +-- crossMap ------------------------------------------------------------------- +-- TODO: What does this do? +crossMapPA :: (PA a, PA b) => (PArray a :-> (a :-> PArray b) :-> PArray (a,b)) +{-# INLINE crossMapPA #-} +crossMapPA = closure2 crossMapPA_v crossMapPA_l + +crossMapPA_v :: (PA a, PA b) => PArray a -> (a :-> PArray b) -> PArray (a,b) +{-# INLINE_PA crossMapPA_v #-} +crossMapPA_v as f + = zipPA# (replicatelPA# (segdPA# bss) as) (concatPA# bss) + where + bss = mapPA_v f as + +crossMapPA_l :: (PA a, PA b) + => PArray (PArray a) + -> PArray (a :-> PArray b) + -> PArray (PArray (a,b)) +{-# INLINE_PA crossMapPA_l #-} +crossMapPA_l ass fs = copySegdPA# bss (zipPA# as' (concatPA# bss)) + where + bsss = mapPA_l fs ass + bss = concatPA_l bsss + as' = replicatelPA# (segdPA# (concatPA# bsss)) (concatPA# ass) + + +-- zip ------------------------------------------------------------------------ +-- | Takes two arrays and returns an array of corresponding pairs. +-- If one array is short, excess elements of the longer array are discarded. +zipPA :: (PA a, PA b) => PArray a :-> PArray b :-> PArray (a,b) +{-# INLINE zipPA #-} +zipPA = closure2 zipPA_v zipPA_l + +zipPA_v :: (PA a, PA b) => PArray a -> PArray b -> PArray (a,b) +{-# INLINE_PA zipPA_v #-} +zipPA_v xs ys = zipPA# xs ys + +zipPA_l :: (PA a, PA b) + => PArray (PArray a) -> PArray (PArray b) -> PArray (PArray (a,b)) +{-# INLINE_PA zipPA_l #-} +zipPA_l (PArray n# (PNested segd xs)) (PArray _ (PNested _ ys)) + = PArray n# (PNested segd (P_2 xs ys)) + + +-- zipWith -------------------------------------------------------------------- +-- | zipWith generalises zip by zipping with the function given as the first +-- argument, instead of a tupling function. +zipWithPA :: (PA a, PA b, PA c) + => (a :-> b :-> c) :-> PArray a :-> PArray b :-> PArray c +{-# INLINE zipWithPA #-} +zipWithPA = closure3 zipWithPA_v zipWithPA_l + +zipWithPA_v :: (PA a, PA b, PA c) + => (a :-> b :-> c) -> PArray a -> PArray b -> PArray c +{-# INLINE_PA zipWithPA_v #-} +zipWithPA_v f as bs = replicatePA# (lengthPA# as) f $:^ as $:^ bs + +zipWithPA_l :: (PA a, PA b, PA c) + => PArray (a :-> b :-> c) -> PArray (PArray a) -> PArray (PArray b) + -> PArray (PArray c) +{-# INLINE_PA zipWithPA_l #-} +zipWithPA_l fs ass bss + = copySegdPA# ass + (replicatelPA# (segdPA# ass) fs $:^ concatPA# ass $:^ concatPA# bss) + + +-- unzip ---------------------------------------------------------------------- +-- | Transform an array into an array of the first components, +-- and an array of the second components. +unzipPA:: (PA a, PA b) => PArray (a, b) :-> (PArray a, PArray b) +{-# INLINE unzipPA #-} +unzipPA = closure1 unzipPA_v unzipPA_l + +unzipPA_v:: (PA a, PA b) => PArray (a,b) -> (PArray a, PArray b) +{-# INLINE_PA unzipPA_v #-} +unzipPA_v abs' = unzipPA# abs' + +unzipPA_l:: (PA a, PA b) => PArray (PArray (a, b)) -> PArray (PArray a, PArray b) +{-# INLINE_PA unzipPA_l #-} +unzipPA_l xyss = zipPA# (copySegdPA# xyss xs) (copySegdPA# xyss ys) + where + (xs, ys) = unzipPA# (concatPA# xyss) + + +-- packPA --------------------------------------------------------------------- +-- | Select the elements of an array that have their tag set as True. +-- +-- @ +-- packPA [12, 24, 42, 93] [True, False, False, True] +-- = [24, 42] +-- @ +-- +packPA :: PA a => PArray a :-> PArray Bool :-> PArray a +{-# INLINE packPA #-} +packPA = closure2 packPA_v packPA_l + +packPA_v :: PA a => PArray a -> PArray Bool -> PArray a +{-# INLINE_PA packPA_v #-} +packPA_v xs bs + = packByTagPA# xs (elementsSel2_1# sel) (U.tagsSel2 sel) 1# + where + sel = boolSel bs + +packPA_l :: PA a + => PArray (PArray a) -> PArray (PArray Bool) -> PArray (PArray a) +{-# INLINE_PA packPA_l #-} +packPA_l (PArray n# xss) (PArray _ bss) + = PArray n# + $ case xss of { PNested segd xs -> + case bss of { PNested _ (PBool sel) -> + PNested (U.lengthsToSegd $ U.count_s segd (U.tagsSel2 sel) 1) + $ packByTagPD xs (elementsSel2_1# sel) (U.tagsSel2 sel) 1# }} + +boolSel :: PArray Bool -> U.Sel2 +{-# INLINE boolSel #-} +boolSel (PArray _ (PBool sel)) = sel + + +-- combine -------------------------------------------------------------------- +-- | Combine two arrays, using a tag array to tell us where to get each element from. +-- +-- @combine2 [1,2,3] [4,5,6] [T,F,F,T,T,F] = [1,4,5,2,3,6]@ +-- +-- TODO: should the selector be a boolean array? +-- +combine2PA:: PA a => PArray a :-> PArray a :-> PArray Tag :-> PArray a +{-# INLINE_PA combine2PA #-} +combine2PA = closure3 combine2PA_v combine2PA_l + +combine2PA_v:: PA a => PArray a -> PArray a -> PArray Tag -> PArray a +{-# INLINE_PA combine2PA_v #-} +combine2PA_v xs ys bs + = combine2PA# (lengthPA# xs +# lengthPA# ys) + (U.tagsToSel2 (toUArrPA bs)) + xs ys + +combine2PA_l + :: PA a + => PArray (PArray a) -> PArray (PArray a) + -> PArray (PArray Tag) + -> PArray (PArray a) +{-# INLINE_PA combine2PA_l #-} +combine2PA_l _ _ _ + = error "dph-common:Data.Array.Parallel.Lifted.Combinators: combinePA_l isn't implemented" + + +-- filter --------------------------------------------------------------------- +-- | Extract the elements from an array that match the given predicate. +filterPA :: PA a => (a :-> Bool) :-> PArray a :-> PArray a +{-# INLINE filterPA #-} +filterPA = closure2 filterPA_v filterPA_l + +filterPA_v :: PA a => (a :-> Bool) -> PArray a -> PArray a +{-# INLINE_PA filterPA_v #-} +filterPA_v p xs = packPA_v xs (mapPA_v p xs) + +filterPA_l :: PA a + => PArray (a :-> Bool) -> PArray (PArray a) -> PArray (PArray a) +{-# INLINE_PA filterPA_l #-} +filterPA_l ps xss = packPA_l xss (mapPA_l ps xss) + + +-- index ---------------------------------------------------------------------- +-- | Retrieve the array element with the given index. +indexPA :: PA a => PArray a :-> Int :-> a +{-# INLINE indexPA #-} +indexPA = closure2 indexPA_v indexPA_l + +indexPA_v :: PA a => PArray a -> Int -> a +{-# INLINE_PA indexPA_v #-} +indexPA_v xs (I# i#) = indexPA# xs i# + +indexPA_l :: PA a => PArray (PArray a) -> PArray Int -> PArray a +{-# INLINE_PA indexPA_l #-} +indexPA_l (PArray _ (PNested segd xs)) (PArray n# is) + = PArray n# + $ bpermutePD xs n# + (U.zipWith (+) (U.indicesSegd segd) + (fromScalarPData is)) + + +-- concat --------------------------------------------------------------------- +-- | Concatenate an array of arrays into a single array. +concatPA :: PA a => PArray (PArray a) :-> PArray a +{-# INLINE concatPA #-} +concatPA = closure1 concatPA_v concatPA_l + +concatPA_v :: PA a => PArray (PArray a) -> PArray a +{-# INLINE_PA concatPA_v #-} +concatPA_v xss = concatPA# xss + +concatPA_l :: PA a => PArray (PArray (PArray a)) -> PArray (PArray a) +{-# INLINE_PA concatPA_l #-} +concatPA_l (PArray m# (PNested segd1 (PNested segd2 xs))) + = PArray m# + (PNested (U.mkSegd (U.sum_s segd1 (U.lengthsSegd segd2)) + (U.bpermute (U.indicesSegd segd2) (U.indicesSegd segd1)) + (U.elementsSegd segd2)) + xs) + + +-- app (append) --------------------------------------------------------------- +-- | Append two arrays. +appPA :: PA a => PArray a :-> PArray a :-> PArray a +{-# INLINE appPA #-} +appPA = closure2 appPA_v appPA_l + +appPA_v :: PA a => PArray a -> PArray a -> PArray a +{-# INLINE_PA appPA_v #-} +appPA_v xs ys = appPA# xs ys + +appPA_l :: PA a => PArray (PArray a) -> PArray (PArray a) -> PArray (PArray a) +{-# INLINE_PA appPA_l #-} +appPA_l (PArray m# pxss) (PArray n# pyss) + = PArray (m# +# n#) + $ case pxss of { PNested xsegd xs -> + case pyss of { PNested ysegd ys -> + let + segd = U.plusSegd xsegd ysegd + in + PNested segd (applPD segd xsegd xs ysegd ys) }} + + +-- enumFromTo ----------------------------------------------------------------- +-- | Produce a range of integers. +enumFromToPA_Int :: Int :-> Int :-> PArray Int +{-# INLINE enumFromToPA_Int #-} +enumFromToPA_Int = closure2 enumFromToPA_v enumFromToPA_l + +enumFromToPA_v :: Int -> Int -> PArray Int +{-# INLINE_PA enumFromToPA_v #-} +enumFromToPA_v m n = fromUArrPA (distance m n) (U.enumFromTo m n) + +distance :: Int -> Int -> Int +{-# INLINE_STREAM distance #-} +distance m n = max 0 (n - m + 1) + +enumFromToPA_l :: PArray Int -> PArray Int -> PArray (PArray Int) +{-# INLINE_PA enumFromToPA_l #-} +enumFromToPA_l (PArray m# ms) (PArray _ ns) + = PArray m# + $ PNested segd + $ toScalarPData + $ U.enumFromStepLenEach (U.elementsSegd segd) + (fromScalarPData ms) (U.replicate (U.elementsSegd segd) 1) lens + where + lens = U.zipWith distance (fromScalarPData ms) (fromScalarPData ns) + segd = U.lengthsToSegd lens + + +-- indexed -------------------------------------------------------------------- +-- | Tag each element of an array with its index. +-- +-- @indexed [42, 93, 13] = [(0, 42), (1, 93), (2, 13)]@ +-- +indexedPA :: PA a => PArray a :-> PArray (Int,a) +{-# INLINE indexedPA #-} +indexedPA = closure1 indexedPA_v indexedPA_l + +indexedPA_v :: PA a => PArray a -> PArray (Int,a) +{-# INLINE indexedPA_v #-} +indexedPA_v (PArray n# xs) + = PArray n# (P_2 (toScalarPData $ U.enumFromStepLen 0 1 (I# n#)) xs) + +indexedPA_l :: PA a => PArray (PArray a) -> PArray (PArray (Int,a)) +{-# INLINE indexedPA_l #-} +indexedPA_l (PArray n# xss) + = PArray n# + $ case xss of { PNested segd xs -> + PNested segd (P_2 (toScalarPData $ U.indices_s segd) xs) } + + +-- slice ---------------------------------------------------------------------- +-- | Extract a subrange of elements from an array. +-- The first argument is the starting index, while the second is the +-- length of the slice. +-- +slicePA :: PA a => Int :-> Int :-> PArray a :-> PArray a +{-# INLINE slicePA #-} +slicePA = closure3 slicePA_v slicePA_l + +slicePA_v :: PA a => Int -> Int -> PArray a -> PArray a +{-# INLINE slicePA_v #-} +slicePA_v (I# from) (I# len) xs + = extractPA# xs from len + +-- TODO: Can we define this in terms of extractPA? +slicePA_l :: PA a => PArray Int -> PArray Int -> PArray (PArray a) -> PArray (PArray a) +{-# INLINE slicePA_l #-} +slicePA_l (PArray n# is) (PArray _ lens) (PArray _ xss) + = PArray n# + $ case xss of { PNested segd xs -> + PNested segd' + $ bpermutePD xs (elementsSegd# segd') + (U.zipWith (+) (U.indices_s segd') + (U.replicate_s segd' + (U.zipWith (+) (fromScalarPData is) + (U.indicesSegd segd)))) } + where + segd' = U.lengthsToSegd (fromScalarPData lens) + + + +-- update --------------------------------------------------------------------- +-- | Copy the source array in the destination, using new values for the given indices. +updatePA :: PA a => PArray a :-> PArray (Int,a) :-> PArray a +{-# INLINE updatePA #-} +updatePA = closure2 updatePA_v updatePA_l + +updatePA_v :: PA a => PArray a -> PArray (Int,a) -> PArray a +{-# INLINE_PA updatePA_v #-} +updatePA_v xs (PArray n# (P_2 is ys)) + = updatePA# xs (fromScalarPData is) (PArray n# ys) + +updatePA_l + :: PA a => PArray (PArray a) -> PArray (PArray (Int,a)) -> PArray (PArray a) +{-# INLINE_PA updatePA_l #-} +updatePA_l (PArray m# xss) (PArray _ pss) + = PArray m# + $ case xss of { PNested segd xs -> + case pss of { PNested segd' (P_2 is ys) -> + PNested segd + $ updatePD xs (U.zipWith (+) (fromScalarPData is) + (U.replicate_s segd' (U.indicesSegd segd))) + ys }} + + +-- bpermute ------------------------------------------------------------------- +-- | Backwards permutation of array elements. +-- +-- @bpermute [50, 60, 20, 30] [0, 3, 2] = [50, 30, 20]@ +-- +bpermutePA :: PA a => PArray a :-> PArray Int :-> PArray a +{-# INLINE bpermutePA #-} +bpermutePA = closure2 bpermutePA_v bpermutePA_l + +bpermutePA_v :: PA a => PArray a -> PArray Int -> PArray a +{-# INLINE_PA bpermutePA_v #-} +bpermutePA_v xs (PArray n# is) = bpermutePA# xs n# (fromScalarPData is) + +bpermutePA_l :: PA a => PArray (PArray a) -> PArray (PArray Int) -> PArray (PArray a) +{-# INLINE_PA bpermutePA_l #-} +bpermutePA_l (PArray _ xss) (PArray n# iss) + = PArray n# + $ case xss of { PNested segd xs -> + case iss of { PNested isegd is -> + PNested isegd + $ bpermutePD xs (elementsSegd# isegd) + (U.zipWith (+) (fromScalarPData is) + (U.replicate_s isegd (U.indicesSegd segd))) }} + + diff --git a/Data/Array/Parallel/Lifted/PArray.hs b/Data/Array/Parallel/Lifted/PArray.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Lifted/PArray.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} + +#include "fusion-phases.h" + +-- +module Data.Array.Parallel.Lifted.PArray ( + PArray(..), PData, + + PA(..), + lengthPA#, dataPA#, replicatePA#, replicatelPA#, repeatPA#, + emptyPA, indexPA#, extractPA#, bpermutePA#, appPA#, applPA#, + packByTagPA#, combine2PA#, updatePA#, fromListPA#, fromListPA, nfPA, + + replicatePD, replicatelPD, repeatPD, emptyPD, + indexPD, extractPD, bpermutePD, appPD, applPD, + packByTagPD, combine2PD, updatePD, fromListPD, nfPD, + + PRepr, PR(..), + + Scalar(..), + replicatePRScalar, replicatelPRScalar, repeatPRScalar, emptyPRScalar, + indexPRScalar, extractPRScalar, bpermutePRScalar, appPRScalar, applPRScalar, + packByTagPRScalar, combine2PRScalar, updatePRScalar, fromListPRScalar, + nfPRScalar, +) where +import Data.Array.Parallel.PArray.PRepr +import Data.Array.Parallel.PArray.Scalar +import Data.Array.Parallel.PArray.PData +import Data.Array.Parallel.PArray.Base + + + + diff --git a/Data/Array/Parallel/Lifted/Scalar.hs b/Data/Array/Parallel/Lifted/Scalar.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Lifted/Scalar.hs @@ -0,0 +1,239 @@ +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} + +#include "fusion-phases.h" + +module Data.Array.Parallel.Lifted.Scalar +where +import Data.Array.Parallel.Lifted.PArray +import Data.Array.Parallel.PArray.PReprInstances +import Data.Array.Parallel.PArray.PDataInstances +import qualified Data.Array.Parallel.Unlifted as U +import Data.Array.Parallel.Base (fromBool, toBool) +import GHC.Exts (Int(..)) + + +-- Pretend Bools are scalars -------------------------------------------------- +instance Scalar Bool where + {-# INLINE toScalarPData #-} + toScalarPData bs + = PBool (U.tagsToSel2 (U.map fromBool bs)) + + {-# INLINE fromScalarPData #-} + fromScalarPData (PBool sel) = U.map toBool (U.tagsSel2 sel) + + +-- Projections ---------------------------------------------------------------- +prim_lengthPA :: Scalar a => PArray a -> Int +{-# INLINE prim_lengthPA #-} +prim_lengthPA xs = I# (lengthPA# xs) + + +-- Conversion ----------------------------------------------------------------- +-- | Create a PArray out of a scalar U.Array, +-- the first argument is the array length. +-- +-- TODO: ditch this version, just use fromUArrPA' +-- +fromUArrPA :: Scalar a => Int -> U.Array a -> PArray a +{-# INLINE fromUArrPA #-} +fromUArrPA (I# n#) xs = PArray n# (toScalarPData xs) + + +-- | Create a PArray out of a scalar U.Array, +-- reading the length directly from the U.Array. +fromUArrPA' :: Scalar a => U.Array a -> PArray a +{-# INLINE fromUArrPA' #-} +fromUArrPA' xs = fromUArrPA (U.length xs) xs + + +-- | Convert a PArray back to a plain U.Array. +toUArrPA :: Scalar a => PArray a -> U.Array a +{-# INLINE toUArrPA #-} +toUArrPA (PArray _ xs) = fromScalarPData xs + + +-- Tuple Conversions ---------------------------------------------------------- +-- | Convert an U.Array of pairs to a PArray. +fromUArrPA_2 + :: (Scalar a, Scalar b) + => Int -> U.Array (a,b) -> PArray (a,b) +{-# INLINE fromUArrPA_2 #-} +fromUArrPA_2 (I# n#) ps + = PArray n# (P_2 (toScalarPData xs) (toScalarPData ys)) + where + (xs,ys) = U.unzip ps + + +-- | Convert a U.Array of pairs to a PArray, +-- reading the length directly from the U.Array. +fromUArrPA_2' + :: (Scalar a, Scalar b) + => U.Array (a,b) -> PArray (a, b) +{-# INLINE fromUArrPA_2' #-} +fromUArrPA_2' ps + = fromUArrPA_2 (U.length ps) ps + + +-- | Convert a U.Array of triples to a PArray. +fromUArrPA_3 + :: (Scalar a, Scalar b, Scalar c) + => Int -> U.Array ((a,b),c) -> PArray (a,b,c) +{-# INLINE fromUArrPA_3 #-} +fromUArrPA_3 (I# n#) ps + = PArray n# (P_3 (toScalarPData xs) + (toScalarPData ys) + (toScalarPData zs)) + where + (qs,zs) = U.unzip ps + (xs,ys) = U.unzip qs + + +-- | Convert a U.Array of triples to a PArray, +-- reading the length directly from the U.Array. +fromUArrPA_3' + :: (Scalar a, Scalar b, Scalar c) + => U.Array ((a,b),c) -> PArray (a, b, c) +{-# INLINE fromUArrPA_3' #-} +fromUArrPA_3' ps = fromUArrPA_3 (U.length ps) ps + + +-- Nesting arrays ------------------------------------------------------------- +-- | O(1). Create a nested array. +nestUSegdPA + :: Int -- ^ total number of elements in the nested array + -> U.Segd -- ^ segment descriptor + -> PArray a -- ^ array of data elements. + -> PArray (PArray a) + +{-# INLINE nestUSegdPA #-} +nestUSegdPA (I# n#) segd (PArray _ xs) + = PArray n# (PNested segd xs) + + +-- | O(1). Create a nested array, +-- using the same length as the source array. +nestUSegdPA' + :: U.Segd -- ^ segment descriptor + -> PArray a -- ^ array of data elements + -> PArray (PArray a) + +{-# INLINE nestUSegdPA' #-} +nestUSegdPA' segd xs + = nestUSegdPA (U.lengthSegd segd) segd xs + + +-- Scalar Operators ----------------------------------------------------------- +-- These work on PArrays of scalar elements. +-- TODO: Why do we need these versions as well as the standard ones? + +-- | Apply a worker function to every element of an array, yielding a new array. +scalar_map + :: (Scalar a, Scalar b) + => (a -> b) -> PArray a -> PArray b + +{-# INLINE_PA scalar_map #-} +scalar_map f xs + = fromUArrPA (prim_lengthPA xs) + . U.map f + $ toUArrPA xs + + +-- | Zip two arrays, yielding a new array. +scalar_zipWith + :: (Scalar a, Scalar b, Scalar c) + => (a -> b -> c) -> PArray a -> PArray b -> PArray c + +{-# INLINE_PA scalar_zipWith #-} +scalar_zipWith f xs ys + = fromUArrPA (prim_lengthPA xs) + $ U.zipWith f (toUArrPA xs) (toUArrPA ys) + + +-- | Zip three arrays, yielding a new array. +scalar_zipWith3 + :: (Scalar a, Scalar b, Scalar c, Scalar d) + => (a -> b -> c -> d) -> PArray a -> PArray b -> PArray c -> PArray d + +{-# INLINE_PA scalar_zipWith3 #-} +scalar_zipWith3 f xs ys zs + = fromUArrPA (prim_lengthPA xs) + $ U.zipWith3 f (toUArrPA xs) (toUArrPA ys) (toUArrPA zs) + + +-- | Left fold over an array. +scalar_fold + :: Scalar a + => (a -> a -> a) -> a -> PArray a -> a + +{-# INLINE_PA scalar_fold #-} +scalar_fold f z + = U.fold f z . toUArrPA + + +-- | Left fold over an array, using the first element to initialise the state. +scalar_fold1 + :: Scalar a + => (a -> a -> a) -> PArray a -> a + +{-# INLINE_PA scalar_fold1 #-} +scalar_fold1 f + = U.fold1 f . toUArrPA + + +-- | Segmented fold of an array of arrays. +-- Each segment is folded individually, yielding an array of the fold results. +scalar_folds + :: Scalar a + => (a -> a -> a) -> a -> PArray (PArray a) -> PArray a + +{-# INLINE_PA scalar_folds #-} +scalar_folds f z xss + = fromUArrPA (prim_lengthPA (concatPA# xss)) + . U.fold_s f z (segdPA# xss) + . toUArrPA + $ concatPA# xss + + +-- | Segmented fold of an array of arrays, using the first element of each +-- segment to initialse the state for that segment. +-- Each segment is folded individually, yielding an array of all the fold results. +scalar_fold1s + :: Scalar a + => (a -> a -> a) -> PArray (PArray a) -> PArray a + +{-# INLINE_PA scalar_fold1s #-} +scalar_fold1s f xss + = fromUArrPA (prim_lengthPA (concatPA# xss)) + . U.fold1_s f (segdPA# xss) + . toUArrPA + $ concatPA# xss + + +-- | Left fold over an array, also passing the index of each element +-- to the parameter function. +scalar_fold1Index + :: Scalar a + => ((Int, a) -> (Int, a) -> (Int, a)) -> PArray a -> Int + +{-# INLINE_PA scalar_fold1Index #-} +scalar_fold1Index f + = fst . U.fold1 f . U.indexed . toUArrPA + + +-- | Segmented fold over an array, also passing the index of each +-- element to the parameter function. +scalar_fold1sIndex + :: Scalar a + => ((Int, a) -> (Int, a) -> (Int, a)) + -> PArray (PArray a) -> PArray Int + +{-# INLINE_PA scalar_fold1sIndex #-} +scalar_fold1sIndex f (PArray m# (PNested segd xs)) + = PArray m# + $ toScalarPData + $ U.fsts + $ U.fold1_s f segd + $ U.zip (U.indices_s segd) + $ fromScalarPData xs + diff --git a/Data/Array/Parallel/Lifted/TH/Repr.hs b/Data/Array/Parallel/Lifted/TH/Repr.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Lifted/TH/Repr.hs @@ -0,0 +1,488 @@ +{-# LANGUAGE TemplateHaskell, Rank2Types #-} +module Data.Array.Parallel.Lifted.TH.Repr ( + scalarInstances, tupleInstances, + voidPRInstance, unitPRInstance, wrapPRInstance +) where + +import qualified Data.Array.Parallel.Unlifted as U +import Data.Array.Parallel.Lifted.PArray +import Data.Array.Parallel.Base.DTrace (traceFn) + +import Language.Haskell.TH +import Data.List (intercalate) + +tyBndrVar :: TyVarBndr -> Name +tyBndrVar (PlainTV n) = n +tyBndrVar (KindedTV n _) = n + +mkAppTs :: Type -> [Type] -> Type +mkAppTs = foldl AppT + +varTs :: [Name] -> [TypeQ] +varTs = map varT + +appTs :: TypeQ -> [TypeQ] -> TypeQ +appTs = foldl appT + +varEs :: [Name] -> [ExpQ] +varEs = map varE + +appEs :: ExpQ -> [ExpQ] -> ExpQ +appEs = foldl appE + +normalMatch :: PatQ -> ExpQ -> MatchQ +normalMatch pat xx = match pat (normalB xx) [] + +varPs :: [Name] -> [PatQ] +varPs = map varP + +vanillaC :: Name -> [TypeQ] -> ConQ +vanillaC con tys = normalC con (map (strictType notStrict) tys) + + +simpleFunD :: Name -> [PatQ] -> ExpQ -> DecQ +simpleFunD name pats xx + = funD name [clause pats (normalB xx) []] + + +inlineD :: Name -> DecQ +inlineD name = pragInlD name (inlineSpecNoPhase True False) + + +instance_PData :: TypeQ -> [Name] -> Name -> [TypeQ] -> DecQ +instance_PData tycon tyargs con tys + = dataInstD (cxt []) ''PData [tycon `appTs` varTs tyargs] + [vanillaC con tys] + [] + + +newtype_instance_PData :: Name -> [Name] -> Name -> TypeQ -> DecQ +newtype_instance_PData tycon tyargs con ty + = newtypeInstD (cxt []) ''PData [conT tycon `appTs` varTs tyargs] + (vanillaC con [ty]) + [] + + +splitConAppTy :: Type -> Maybe (Type, [Type]) +splitConAppTy ty = collect ty [] + where + collect (ConT tycon) args = Just (ConT tycon, args) + collect (TupleT n) args = Just (TupleT n, args) + collect ListT args = Just (ListT, args) + collect ArrowT args = Just (ArrowT, args) + collect (AppT t arg) args = collect t (arg:args) + collect _ _ = Nothing + + +normaliseTy :: Type -> Q Type +normaliseTy ty + = case splitConAppTy ty of + Just (ConT tycon, args) + -> do + info <- reify tycon + case info of + TyConI (TySynD _ bndrs t) + -> return $ substTy (zip (map tyBndrVar bndrs) args) t + _ -> return ty + _ -> return ty + + +substTy :: [(Name, Type)] -> Type -> Type +substTy _ (ForallT _ _ _) + = error "DPH gen: can't substitute in forall ty" + +substTy env (VarT v) = case lookup v env of + Just ty -> ty + Nothing -> VarT v +substTy env (AppT t u) = AppT (substTy env t) (substTy env u) +substTy env (SigT t k) = SigT (substTy env t) k +substTy _ t = t + + +splitFunTy :: Type -> ([Type], Type) +splitFunTy ty = case splitConAppTy ty of + Just (ArrowT, [arg, r]) -> let (args, res) = splitFunTy r + in (arg:args, res) + _ -> ([], ty) + +data Val = ScalarVal + | PDataVal + | ListVal + | UnitVal + | OtherVal +type NameGen = String -> String +type ArgVal = (Val, NameGen) + +genPR_methods :: (Name -> [ArgVal] -> Val -> DecQ) -> Q [Dec] +genPR_methods mk_method + = do + ClassI (ClassD _ _ _ _ decs) _ <- reify ''PR + inls <- sequence [inlineD $ mkName $ nameBase name | SigD name _ <- decs] + defs <- mapM gen [(name, ty) | SigD name ty <- decs] + return $ inls ++ defs + where + gen (name, ty) + = case lookup name nameGens of + Just gs -> do + (args, res) <- methodVals ty + mk_method name (zip args gs) res + Nothing -> error $ "DPH gen: no name generator for " ++ show name + + +methodVals :: Type -> Q ([Val], Val) +methodVals (ForallT (PlainTV vv : _) _ ty) + = do + ty' <- normaliseTy ty + let (args, res) = splitFunTy ty' + + return (map (val vv) args, val vv res) + where + val v (VarT n) | v == n = ScalarVal + + val v (AppT (ConT c) (VarT n)) + | c == ''PData && v == n = PDataVal + | c == ''[] && v == n = ListVal + + val v (AppT ListT (VarT n)) | v==n = ListVal + val _ (ConT c) | c == ''() = UnitVal + val _ (TupleT 0) = UnitVal + val _ _ = OtherVal + +methodVals tt + = error $ "DPH gen: methodVals: no match for " ++ show tt + + +data Split = PatSplit PatQ + | CaseSplit PatQ ExpQ PatQ + +data Arg = RecArg [ExpQ] [ExpQ] + | OtherArg ExpQ + +data Gen = Gen { + recursiveCalls :: Int + , recursiveName :: Name -> Name + , split :: ArgVal -> (Split, Arg) + , join :: Val -> [ExpQ] -> ExpQ + , typeName :: String + } + +recursiveMethod :: Gen -> Name -> [ArgVal] -> Val -> DecQ +recursiveMethod gen name avs res + = simpleFunD (mkName $ nameBase name) (map pat splits) + $ appE (varE 'traceFn `appEs` [stringE (nameBase name), stringE (typeName gen)]) + $ foldr mk_case + (join gen res + . recurse (recursiveCalls gen) + . trans + $ map expand args) + splits + where + (splits, args) = unzip (map split_arg avs) + + pat (PatSplit p) = p + pat (CaseSplit p _ _) = p + + split_arg (OtherVal, g) + = let v = mkName (g "") + in (PatSplit (varP v), OtherArg (varE v)) + + split_arg arg = split gen arg + + mk_case (PatSplit _) xx = xx + mk_case (CaseSplit _ scrut pat') xx = caseE scrut [normalMatch pat' xx] + + expand (RecArg _ es) = es + expand (OtherArg e) = repeat e + + trans [] = [] + trans [xs] = [[x] | x <- xs] + trans (xs : yss) = zipWith (:) xs (trans yss) + + recurse 0 _ = [] + recurse n [] = replicate n (varE rec_name) + recurse n args' = [varE rec_name `appEs` es | es <- take n args'] + + rec_name = recursiveName gen name + + +nameGens :: [(Name, [[Char] -> [Char]])] +nameGens = + [ + ('emptyPR, []) + , ('replicatePR, [const "n#", id]) + , ('replicatelPR, [const "segd", id]) + , ('repeatPR, [const "n#", const "len#", id]) + , ('indexPR, [id, const "i#"]) + , ('extractPR, [id, const "i#", const "n#"]) + , ('bpermutePR, [id, const "n#", const "is"]) + , ('appPR, [(++"1"), (++"2")]) + , ('applPR, [const "segd", const "is", (++"1"), const "js", (++"2")]) + , ('packByTagPR, [id, const "n#", const "tags", const "t#"]) + , ('combine2PR, [const "n#", const "sel", (++"1"), (++"2")]) + , ('updatePR, [(++"1"), const "is", (++"2")]) + , ('fromListPR, [const "n#", id]) + , ('nfPR, [id]) + ] + +-- --------------- +-- Scalar types +-- --------------- + +scalarInstances :: [Name] -> Q [Dec] +scalarInstances tys + = do + pdatas <- mapM instance_PData_scalar tys + scalars <- mapM instance_Scalar_scalar tys + prs <- mapM instance_PR_scalar tys + return $ pdatas ++ scalars ++ prs + +pdataScalarCon :: Name -> Name +pdataScalarCon n = mkName ("P" ++ nameBase n) + +instance_PData_scalar :: Name -> DecQ +instance_PData_scalar tycon + = newtype_instance_PData tycon [] (pdataScalarCon tycon) + (conT ''U.Array `appT` conT tycon) + +instance_Scalar_scalar :: Name -> DecQ +instance_Scalar_scalar ty + = instanceD (cxt []) + (conT ''Scalar `appT` conT ty) + (map (inlineD . mkName . fst) methods ++ map snd methods) + where + pcon = pdataScalarCon ty + xs = mkName "xs" + + methods = [("fromScalarPData", mk_fromScalarPData), + ("toScalarPData", mk_toScalarPData)] + + mk_fromScalarPData = simpleFunD (mkName "fromScalarPData") + [conP pcon [varP xs]] + (varE xs) + mk_toScalarPData = simpleFunD (mkName "toScalarPData") [] (conE pcon) + +instance_PR_scalar :: Name -> DecQ +instance_PR_scalar ty + = do + methods <- genPR_methods (scalarMethod ty) + return $ InstanceD [] + (ConT ''PR `AppT` ConT ty) + methods + +scalarMethod :: Name -> Name -> [ArgVal] -> Val -> DecQ +scalarMethod _ meth _ _ + = simpleFunD (mkName $ nameBase meth) [] + $ varE + $ mkName (nameBase meth ++ "Scalar") + +{- + = simpleFunD (mkName $ nameBase meth) pats + $ result res + $ varE impl `appEs` vals + where + pcon = pdataPrimCon ty + impl = mkName + $ nameBase meth ++ "Prim" + + (pats, vals) = unzip [arg v g | (v,g) <- avs] + + arg ScalarVal g = var (g "x") + arg PDataVal g = let v = mkName (g "xs") + in (conP pcon [varP v], varE v) + arg ListVal g = var (g "xs") + arg OtherVal g = var (g "") + + var s = let v = mkName s in (varP v, varE v) + + result ScalarVal e = e + result PDataVal e = conE pcon `appE` e + result UnitVal e = varE 'seq `appEs` [e, varE '()] + result OtherVal e = e +-} + +-- ---- +-- Void +-- ---- + +voidPRInstance :: Name -> Name -> Name -> Q [Dec] +voidPRInstance ty void pvoid + = do + methods <- genPR_methods (voidMethod void pvoid) + return [InstanceD [] + (ConT ''PR `AppT` ConT ty) + methods] + +voidMethod :: Name -> Name -> Name -> [ArgVal] -> Val -> DecQ +voidMethod void pvoid meth avs res + = simpleFunD (mkName $ nameBase meth) (map (const wildP) avs) + $ result res + where + result ScalarVal = varE void + result PDataVal = varE pvoid + result UnitVal = conE '() + result _ = error "DPH gen: voidMethod: no match" + +-- -- +-- () +-- -- + +unitPRInstance :: Name -> Q [Dec] +unitPRInstance punit + = do + methods <- genPR_methods (unitMethod punit) + return [InstanceD [] + (ConT ''PR `AppT` ConT ''()) + methods] + +unitMethod :: Name -> Name -> [ArgVal] -> Val -> DecQ +unitMethod punit meth avs res + = simpleFunD (mkName $ nameBase meth) pats + $ foldr seq_val (result res) es + where + (pats, es) = unzip [mkpat v g | (v,g) <- avs] + + mkpat ScalarVal _ = (conP '() [], Nothing) + mkpat PDataVal _ = (conP punit [], Nothing) + + mkpat ListVal g + = let xs = mkName (g "xs") + in (varP xs, Just $ \e -> varE 'foldr `appEs` [varE 'seq, e, varE xs]) + + mkpat OtherVal _ = (wildP, Nothing) + mkpat _ _ = error "DPH gen: unitMethod/mkpat: no match" + + result ScalarVal = conE '() + result PDataVal = conE punit + result UnitVal = conE '() + result _ = error "DPH gen: unitMethod/result: no match" + + seq_val Nothing e = e + seq_val (Just f) e = f e + +-- ---- +-- Wrap +-- ---- + +wrapPRInstance :: Name -> Name -> Name -> Name -> Q [Dec] +wrapPRInstance ty wrap unwrap pwrap + = do + methods <- genPR_methods (recursiveMethod (wrapGen wrap unwrap pwrap)) + return [InstanceD [ClassP ''PA [a]] + (ConT ''PR `AppT` (ConT ty `AppT` a)) + methods] + where + a = VarT (mkName "a") + +wrapGen :: Name -> Name -> Name -> Gen +wrapGen wrap unwrap pwrap + = Gen { recursiveCalls = 1 + , recursiveName = recursiveName' + , split = split' + , join = join' + , typeName = "Wrap a" + } + where + recursiveName' = mkName . replace . nameBase + where + replace s = init s ++ "D" + + split' (ScalarVal, gen) + = (PatSplit (conP wrap [varP x]), RecArg [] [varE x]) + where + x = mkName (gen "x") + + split' (PDataVal, gen) + = (PatSplit (conP pwrap [varP xs]), RecArg [] [varE xs]) + where + xs = mkName (gen "xs") + + split' (ListVal, gen) + = (PatSplit (varP xs), + RecArg [] [varE 'map `appEs` [varE unwrap, varE xs]]) + where + xs = mkName (gen "xs") + + split' _ = error "DPH gen: split': no match" + + + join' ScalarVal [x] = conE wrap `appE` x + join' PDataVal [xs] = conE pwrap `appE` xs + join' UnitVal [x] = x + join' _ _ = error "DPH gen: wrapGen: no match" + + +-- ------ +-- Tuples +-- ------ + +tupleInstances :: [Int] -> Q [Dec] +tupleInstances ns + = do + pdatas <- mapM instance_PData_tup ns + prs <- mapM instance_PR_tup ns + return $ pdatas ++ prs + +pdataTupCon :: Int -> Name +pdataTupCon n = mkName ("P_" ++ show n) + +instance_PData_tup :: Int -> DecQ +instance_PData_tup arity + = instance_PData (tupleT arity) vars (pdataTupCon arity) + [conT ''PData `appT` varT v | v <- vars] + where + vars = take arity $ [mkName [c] | c <- ['a' .. ]] + + +instance_PR_tup :: Int -> DecQ +instance_PR_tup arity + = do + methods <- genPR_methods (recursiveMethod (tupGen arity)) + return $ InstanceD [ClassP ''PR [ty] | ty <- tys] + (ConT ''PR `AppT` (TupleT arity `mkAppTs` tys)) + methods + where + tys = take arity $ [VarT $ mkName [c] | c <- ['a' .. ]] + +tupGen :: Int -> Gen +tupGen arity = Gen { recursiveCalls = arity + , recursiveName = id + , split = split' + , join = join' + , typeName = tyname + } + where + split' (ScalarVal, gen) + = (PatSplit (tupP $ varPs names), RecArg [] (varEs names)) + where + names = map (mkName . gen) vs + + split' (PDataVal, gen) + = (PatSplit (conP (pdataTupCon arity) $ varPs names), + RecArg [] (varEs names)) + where + names = map (mkName . gen) pvs + + split' (ListVal, gen) + = (CaseSplit (varP xs) (varE mkunzip `appE` varE xs) + (tupP $ varPs names), + RecArg [] (varEs names)) + where + xs = mkName (gen "xs") + names = map (mkName . gen) pvs + + mkunzip | arity == 2 = mkName "unzip" + | otherwise = mkName ("unzip" ++ show arity) + + split' _ = error "DPH Gen: tupGen/split: no match" + + + join' ScalarVal xs = tupE xs + join' PDataVal xs = conE (pdataTupCon arity) `appEs` xs + join' UnitVal xs = foldl1 (\x y -> varE 'seq `appEs` [x,y]) xs + join' _ _ = error "DPH Gen: tupGen/join: no match" + + vs = take arity [[c] | c <- ['a' ..]] + pvs = take arity [c : "s" | c <- ['a' ..]] + + tyname = "(" ++ intercalate "," vs ++ ")" + diff --git a/Data/Array/Parallel/Lifted/Unboxed.hs b/Data/Array/Parallel/Lifted/Unboxed.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Lifted/Unboxed.hs @@ -0,0 +1,449 @@ +{-# LANGUAGE CPP #-} + +#include "fusion-phases.h" + +module Data.Array.Parallel.Lifted.Unboxed ( + Segd, elementsSegd#, mkSegd#, + Sel2, elementsSel2_0#, elementsSel2_1#, replicateSel2#, pickSel2#, tagsSel2, + + PArray_Int#, + lengthPA_Int#, emptyPA_Int#, + replicatePA_Int#, replicatelPA_Int#, repeatPA_Int#, + indexPA_Int#, extractPA_Int#, bpermutePA_Int#, + appPA_Int#, applPA_Int#, + packPA_Int#, pack'PA_Int#, combine2PA_Int#, combine2'PA_Int#, + fromListPA_Int#, + upToPA_Int#, enumFromToPA_Int#, enumFromThenToPA_Int#, + enumFromStepLenPA_Int#, + selectPA_Int#, selectorToIndices2PA#, + -- lengthSegdPA#, lengthsSegdPA#, indicesSegdPA#, elementsSegdPA#, + -- lengthsToSegdPA#, mkSegdPA#, + sumPA_Int#, sumPAs_Int#, + unsafe_mapPA_Int#, unsafe_zipWithPA_Int#, unsafe_foldPA_Int#, + unsafe_scanPA_Int#, + + PArray_Word8#, + lengthPA_Word8#, emptyPA_Word8#, + replicatePA_Word8#, replicatelPA_Word8#, repeatPA_Word8#, + indexPA_Word8#, extractPA_Word8#, bpermutePA_Word8#, + appPA_Word8#, applPA_Word8#, + packPA_Word8#, pack'PA_Word8#, combine2PA_Word8#, combine2'PA_Word8#, + fromListPA_Word8#, + unsafe_zipWithPA_Word8#, unsafe_foldPA_Word8#, unsafe_fold1PA_Word8#, + unsafe_foldPAs_Word8#, + + PArray_Double#, + lengthPA_Double#, emptyPA_Double#, + replicatePA_Double#, replicatelPA_Double#, repeatPA_Double#, + indexPA_Double#, extractPA_Double#, bpermutePA_Double#, + appPA_Double#, applPA_Double#, + packPA_Double#, pack'PA_Double#, combine2PA_Double#, combine2'PA_Double#, + fromListPA_Double#, + unsafe_zipWithPA_Double#, unsafe_foldPA_Double#, unsafe_fold1PA_Double#, + unsafe_foldPAs_Double#, + + PArray_Bool#, + lengthPA_Bool#, replicatelPA_Bool#, + packPA_Bool#, truesPA_Bool#, truesPAs_Bool#, + + fromBoolPA#, toBoolPA# +) where + +import qualified Data.Array.Parallel.Unlifted as U +import Data.Array.Parallel.Base ( + Tag, fromBool, toBool, intToTag, tagToInt ) + +import GHC.Exts ( Int#, Int(..), Word#, + Double#, Double(..) ) +import GHC.Word ( Word8(..) ) + +type Segd = U.Segd +type Sel2 = U.Sel2 + +elementsSegd# :: Segd -> Int# +elementsSegd# segd = case U.elementsSegd segd of { I# n# -> n# } +{-# INLINE_PA elementsSegd# #-} + +mkSegd# :: U.Array Int -> U.Array Int -> Int# -> Segd +mkSegd# ns is n# = U.mkSegd ns is (I# n#) +{-# INLINE_PA mkSegd# #-} + +{-# RULES + +"mkSegd#" forall ns is n#. + mkSegd# ns is n# = U.mkSegd ns is (I# n#) + + #-} + +replicateSel2# :: Int# -> Int# -> Sel2 +{-# INLINE replicateSel2# #-} +replicateSel2# n# tag# = U.mkSel2 (U.replicate n (intToTag tag)) + (U.enumFromStepLen 0 1 n) + (if tag == 0 then n else 0) + (if tag == 0 then 0 else n) + (U.mkSelRep2 (U.replicate n (intToTag tag))) + where + n = I# n# + tag = I# tag# + +pickSel2# :: Sel2 -> Int# -> U.Array Bool +{-# INLINE pickSel2# #-} +pickSel2# sel tag# = U.pick (U.tagsSel2 sel) (intToTag (I# tag#)) + +tagsSel2 :: Sel2 -> U.Array Tag +{-# INLINE tagsSel2 #-} +tagsSel2 = U.tagsSel2 + +elementsSel2_0# :: Sel2 -> Int# +elementsSel2_0# sel = case U.elementsSel2_0 sel of { I# n# -> n# } +{-# INLINE_PA elementsSel2_0# #-} + +elementsSel2_1# :: Sel2 -> Int# +elementsSel2_1# sel = case U.elementsSel2_1 sel of { I# n# -> n# } +{-# INLINE_PA elementsSel2_1# #-} + +type PArray_Int# = U.Array Int + +lengthPA_Int# :: PArray_Int# -> Int# +lengthPA_Int# arr = case U.length arr of { I# n# -> n# } +{-# INLINE_PA lengthPA_Int# #-} + +emptyPA_Int# :: PArray_Int# +emptyPA_Int# = U.empty +{-# INLINE_PA emptyPA_Int# #-} + +replicatePA_Int# :: Int# -> Int# -> PArray_Int# +replicatePA_Int# n# i# = U.replicate (I# n#) (I# i#) +{-# INLINE_PA replicatePA_Int# #-} + +{-# RULES + +"replicatePA_Int#" forall n# i#. + replicatePA_Int# n# i# = U.replicate (I# n#) (I# i#) + + #-} + +replicatelPA_Int# :: Segd -> PArray_Int# -> PArray_Int# +replicatelPA_Int# segd is = U.replicate_s segd is +{-# INLINE_PA replicatelPA_Int# #-} + +{-# RULES + +"replicatelPA_Int#" forall segd is. + replicatelPA_Int# segd is = U.replicate_s segd is + + #-} + +repeatPA_Int# :: Int# -> Int# -> PArray_Int# -> PArray_Int# +repeatPA_Int# n# len# is = U.repeat (I# n#) (I# len#) is +{-# INLINE_PA repeatPA_Int# #-} + +indexPA_Int# :: PArray_Int# -> Int# -> Int# +indexPA_Int# ns i# = case ns U.!: I# i# of { I# n# -> n# } +{-# INLINE_PA indexPA_Int# #-} + +extractPA_Int# :: PArray_Int# -> Int# -> Int# -> PArray_Int# +extractPA_Int# xs i# n# = U.extract xs (I# i#) (I# n#) +{-# INLINE_PA extractPA_Int# #-} + +bpermutePA_Int# :: PArray_Int# -> PArray_Int# -> PArray_Int# +bpermutePA_Int# ns is = U.bpermute ns is +{-# INLINE_PA bpermutePA_Int# #-} + +appPA_Int# :: PArray_Int# -> PArray_Int# -> PArray_Int# +appPA_Int# ms ns = ms U.+:+ ns +{-# INLINE_PA appPA_Int# #-} + +applPA_Int# :: Segd -> Segd -> PArray_Int# -> Segd -> PArray_Int# -> PArray_Int# +applPA_Int# segd is xs js ys = U.append_s segd is xs js ys +{-# INLINE_PA applPA_Int# #-} + +pack'PA_Int# :: PArray_Int# -> PArray_Bool# -> PArray_Int# +pack'PA_Int# ns bs = U.pack ns bs +{-# INLINE_PA pack'PA_Int# #-} + +packPA_Int# :: PArray_Int# -> Int# -> PArray_Bool# -> PArray_Int# +packPA_Int# ns _ bs = pack'PA_Int# ns bs +{-# INLINE_PA packPA_Int# #-} + +combine2'PA_Int# :: PArray_Int# -> PArray_Int# -> PArray_Int# -> PArray_Int# +combine2'PA_Int# sel xs ys = U.combine (U.map (== 0) sel) xs ys +{-# INLINE_PA combine2'PA_Int# #-} + +combine2PA_Int# :: Int# -> PArray_Int# -> PArray_Int# + -> PArray_Int# -> PArray_Int# -> PArray_Int# +combine2PA_Int# _ sel _ xs ys = combine2'PA_Int# sel xs ys +{-# INLINE_PA combine2PA_Int# #-} + +fromListPA_Int# :: Int# -> [Int] -> PArray_Int# +fromListPA_Int# _ xs = U.fromList xs +{-# INLINE_PA fromListPA_Int# #-} + +upToPA_Int# :: Int# -> PArray_Int# +upToPA_Int# n# = U.enumFromTo 0 (I# n# - 1) +{-# INLINE_PA upToPA_Int# #-} + +enumFromToPA_Int# :: Int# -> Int# -> PArray_Int# +enumFromToPA_Int# m# n# = U.enumFromTo (I# m#) (I# n#) +{-# INLINE_PA enumFromToPA_Int# #-} + +enumFromThenToPA_Int# :: Int# -> Int# -> Int# -> PArray_Int# +enumFromThenToPA_Int# k# m# n# = U.enumFromThenTo (I# k#) (I# m#) (I# n#) +{-# INLINE_PA enumFromThenToPA_Int# #-} + +enumFromStepLenPA_Int# :: Int# -> Int# -> Int# -> PArray_Int# +enumFromStepLenPA_Int# k# m# n# = U.enumFromStepLen (I# k#) (I# m#) (I# n#) +{-# INLINE_PA enumFromStepLenPA_Int# #-} + +selectPA_Int# :: PArray_Int# -> Int# -> PArray_Bool# +selectPA_Int# ns i# = U.map (\n -> n == I# i#) ns +{-# INLINE_PA selectPA_Int# #-} + + +selectorToIndices2PA# :: PArray_Int# -> PArray_Int# +selectorToIndices2PA# sel + = U.zipWith pick sel + . U.scan index (0,0) + $ U.map init' sel + where + init' 0 = (1,0) + init' _ = (0,1) + + index (i1,j1) (i2,j2) = (i1+i2,j1+j2) + + pick 0 (i,_) = i + pick _ (_,j) = j +{-# INLINE_PA selectorToIndices2PA# #-} + +sumPA_Int# :: PArray_Int# -> Int# +sumPA_Int# ns = case U.sum ns of I# n# -> n# +{-# INLINE_PA sumPA_Int# #-} + +sumPAs_Int# :: Segd -> PArray_Int# -> PArray_Int# +sumPAs_Int# segd ds = U.sum_s segd ds +{-# INLINE_PA sumPAs_Int# #-} + +unsafe_mapPA_Int# :: (Int -> Int) -> PArray_Int# -> PArray_Int# +unsafe_mapPA_Int# f ns = U.map f ns +{-# INLINE_PA unsafe_mapPA_Int# #-} + +unsafe_zipWithPA_Int# :: (Int -> Int -> Int) + -> PArray_Int# -> PArray_Int# -> PArray_Int# +unsafe_zipWithPA_Int# f ms ns = U.zipWith f ms ns +{-# INLINE_PA unsafe_zipWithPA_Int# #-} + +unsafe_foldPA_Int# :: (Int -> Int -> Int) -> Int -> PArray_Int# -> Int +unsafe_foldPA_Int# f z ns = U.fold f z ns +{-# INLINE_PA unsafe_foldPA_Int# #-} + +unsafe_scanPA_Int# :: (Int -> Int -> Int) -> Int -> PArray_Int# -> PArray_Int# +unsafe_scanPA_Int# f z ns = U.scan f z ns +{-# INLINE_PA unsafe_scanPA_Int# #-} + +type PArray_Word8# = U.Array Word8 + +lengthPA_Word8# :: PArray_Word8# -> Int# +lengthPA_Word8# arr = case U.length arr of { I# n# -> n# } +{-# INLINE_PA lengthPA_Word8# #-} + +emptyPA_Word8# :: PArray_Word8# +emptyPA_Word8# = U.empty +{-# INLINE_PA emptyPA_Word8# #-} + +replicatePA_Word8# :: Int# -> Word# -> PArray_Word8# +replicatePA_Word8# n# d# = U.replicate (I# n#) (W8# d#) +{-# INLINE_PA replicatePA_Word8# #-} + +replicatelPA_Word8# :: Segd -> PArray_Word8# -> PArray_Word8# +replicatelPA_Word8# segd ds = U.replicate_s segd ds +{-# INLINE_PA replicatelPA_Word8# #-} + +repeatPA_Word8# :: Int# -> Int# -> PArray_Word8# -> PArray_Word8# +repeatPA_Word8# n# len# ds = U.repeat (I# n#) (I# len#) ds +{-# INLINE_PA repeatPA_Word8# #-} + +indexPA_Word8# :: PArray_Word8# -> Int# -> Word# +indexPA_Word8# ds i# = case ds U.!: I# i# of { W8# d# -> d# } +{-# INLINE_PA indexPA_Word8# #-} + +extractPA_Word8# :: PArray_Word8# -> Int# -> Int# -> PArray_Word8# +extractPA_Word8# xs i# n# = U.extract xs (I# i#) (I# n#) +{-# INLINE_PA extractPA_Word8# #-} + +bpermutePA_Word8# :: PArray_Word8# -> PArray_Int# -> PArray_Word8# +bpermutePA_Word8# ds is = U.bpermute ds is +{-# INLINE_PA bpermutePA_Word8# #-} + +appPA_Word8# :: PArray_Word8# -> PArray_Word8# -> PArray_Word8# +appPA_Word8# ms ns = ms U.+:+ ns +{-# INLINE_PA appPA_Word8# #-} + +applPA_Word8# :: Segd -> Segd -> PArray_Word8# -> Segd -> PArray_Word8# + -> PArray_Word8# +applPA_Word8# segd is xs js ys = U.append_s segd is xs js ys +{-# INLINE_PA applPA_Word8# #-} + +pack'PA_Word8# :: PArray_Word8# -> PArray_Bool# -> PArray_Word8# +pack'PA_Word8# ns bs = U.pack ns bs +{-# INLINE_PA pack'PA_Word8# #-} + +packPA_Word8# :: PArray_Word8# -> Int# -> PArray_Bool# -> PArray_Word8# +packPA_Word8# ns _ bs = pack'PA_Word8# ns bs +{-# INLINE_PA packPA_Word8# #-} + +combine2'PA_Word8# :: PArray_Int# + -> PArray_Word8# -> PArray_Word8# -> PArray_Word8# +combine2'PA_Word8# sel xs ys = U.combine (U.map (== 0) sel) xs ys +{-# INLINE_PA combine2'PA_Word8# #-} + +combine2PA_Word8# :: Int# -> PArray_Int# -> PArray_Int# + -> PArray_Word8# -> PArray_Word8# -> PArray_Word8# +combine2PA_Word8# _ sel _ xs ys = combine2'PA_Word8# sel xs ys +{-# INLINE_PA combine2PA_Word8# #-} + +fromListPA_Word8# :: Int# -> [Word8] -> PArray_Word8# +fromListPA_Word8# _ xs = U.fromList xs +{-# INLINE_PA fromListPA_Word8# #-} + +unsafe_zipWithPA_Word8# :: (Word8 -> Word8 -> Word8) + -> PArray_Word8# -> PArray_Word8# -> PArray_Word8# +unsafe_zipWithPA_Word8# f ms ns = U.zipWith f ms ns +{-# INLINE_PA unsafe_zipWithPA_Word8# #-} + +unsafe_foldPA_Word8# :: (Word8 -> Word8 -> Word8) + -> Word8 -> PArray_Word8# -> Word8 +unsafe_foldPA_Word8# f z ns = U.fold f z ns +{-# INLINE_PA unsafe_foldPA_Word8# #-} + +unsafe_fold1PA_Word8# + :: (Word8 -> Word8 -> Word8) -> PArray_Word8# -> Word8 +unsafe_fold1PA_Word8# f ns = U.fold1 f ns +{-# INLINE_PA unsafe_fold1PA_Word8# #-} + +unsafe_foldPAs_Word8# :: (Word8 -> Word8 -> Word8) -> Word8 + -> Segd -> PArray_Word8# -> PArray_Word8# +unsafe_foldPAs_Word8# f z segd ds = U.fold_s f z segd ds +{-# INLINE_PA unsafe_foldPAs_Word8# #-} + +type PArray_Double# = U.Array Double + +lengthPA_Double# :: PArray_Double# -> Int# +lengthPA_Double# arr = case U.length arr of { I# n# -> n# } +{-# INLINE_PA lengthPA_Double# #-} + +emptyPA_Double# :: PArray_Double# +emptyPA_Double# = U.empty +{-# INLINE_PA emptyPA_Double# #-} + +replicatePA_Double# :: Int# -> Double# -> PArray_Double# +replicatePA_Double# n# d# = U.replicate (I# n#) (D# d#) +{-# INLINE_PA replicatePA_Double# #-} + +replicatelPA_Double# :: Segd -> PArray_Double# -> PArray_Double# +replicatelPA_Double# segd ds = U.replicate_s segd ds +{-# INLINE_PA replicatelPA_Double# #-} + +repeatPA_Double# :: Int# -> Int# -> PArray_Double# -> PArray_Double# +repeatPA_Double# n# len# ds = U.repeat (I# n#) (I# len#) ds +{-# INLINE_PA repeatPA_Double# #-} + +{-# RULES + +"repeatPA_Double#" forall n# len# ds. + repeatPA_Double# n# len# ds = U.repeat (I# n#) (I# len#) ds + + #-} + +indexPA_Double# :: PArray_Double# -> Int# -> Double# +indexPA_Double# ds i# = case ds U.!: I# i# of { D# d# -> d# } +{-# INLINE_PA indexPA_Double# #-} + +extractPA_Double# :: PArray_Double# -> Int# -> Int# -> PArray_Double# +extractPA_Double# xs i# n# = U.extract xs (I# i#) (I# n#) +{-# INLINE_PA extractPA_Double# #-} + +bpermutePA_Double# :: PArray_Double# -> PArray_Int# -> PArray_Double# +bpermutePA_Double# ds is = U.bpermute ds is +{-# INLINE_PA bpermutePA_Double# #-} + +appPA_Double# :: PArray_Double# -> PArray_Double# -> PArray_Double# +appPA_Double# ms ns = ms U.+:+ ns +{-# INLINE_PA appPA_Double# #-} + +applPA_Double# :: Segd -> Segd -> PArray_Double# -> Segd -> PArray_Double# + -> PArray_Double# +applPA_Double# segd is xs js ys = U.append_s segd is xs js ys +{-# INLINE_PA applPA_Double# #-} + +pack'PA_Double# :: PArray_Double# -> PArray_Bool# -> PArray_Double# +pack'PA_Double# ns bs = U.pack ns bs +{-# INLINE_PA pack'PA_Double# #-} + +packPA_Double# :: PArray_Double# -> Int# -> PArray_Bool# -> PArray_Double# +packPA_Double# ns _ bs = pack'PA_Double# ns bs +{-# INLINE_PA packPA_Double# #-} + +combine2'PA_Double# :: PArray_Int# + -> PArray_Double# -> PArray_Double# -> PArray_Double# +combine2'PA_Double# sel xs ys = U.combine (U.map (== 0) sel) xs ys +{-# INLINE_PA combine2'PA_Double# #-} + +combine2PA_Double# :: Int# -> PArray_Int# -> PArray_Int# + -> PArray_Double# -> PArray_Double# -> PArray_Double# +combine2PA_Double# _ sel _ xs ys = combine2'PA_Double# sel xs ys +{-# INLINE_PA combine2PA_Double# #-} + +fromListPA_Double# :: Int# -> [Double] -> PArray_Double# +fromListPA_Double# _ xs = U.fromList xs +{-# INLINE_PA fromListPA_Double# #-} + +unsafe_zipWithPA_Double# :: (Double -> Double -> Double) + -> PArray_Double# -> PArray_Double# -> PArray_Double# +unsafe_zipWithPA_Double# f ms ns = U.zipWith f ms ns +{-# INLINE_PA unsafe_zipWithPA_Double# #-} + +unsafe_foldPA_Double# :: (Double -> Double -> Double) + -> Double -> PArray_Double# -> Double +unsafe_foldPA_Double# f z ns = U.fold f z ns +{-# INLINE_PA unsafe_foldPA_Double# #-} + +unsafe_fold1PA_Double# + :: (Double -> Double -> Double) -> PArray_Double# -> Double +unsafe_fold1PA_Double# f ns = U.fold1 f ns +{-# INLINE_PA unsafe_fold1PA_Double# #-} + +unsafe_foldPAs_Double# :: (Double -> Double -> Double) -> Double + -> Segd -> PArray_Double# -> PArray_Double# +unsafe_foldPAs_Double# f z segd ds = U.fold_s f z segd ds +{-# INLINE_PA unsafe_foldPAs_Double# #-} + +type PArray_Bool# = U.Array Bool + +lengthPA_Bool# :: PArray_Bool# -> Int# +lengthPA_Bool# arr = case U.length arr of { I# n# -> n# } +{-# INLINE_PA lengthPA_Bool# #-} + +replicatelPA_Bool# :: Segd -> PArray_Bool# -> PArray_Bool# +replicatelPA_Bool# segd ds = U.replicate_s segd ds +{-# INLINE_PA replicatelPA_Bool# #-} + +packPA_Bool# :: PArray_Bool# -> Int# -> PArray_Bool# -> PArray_Bool# +packPA_Bool# ns _ bs = U.pack ns bs +{-# INLINE_PA packPA_Bool# #-} + +truesPA_Bool# :: PArray_Bool# -> Int# +truesPA_Bool# bs = sumPA_Int# (fromBoolPA# bs) +{-# INLINE_PA truesPA_Bool# #-} + +truesPAs_Bool# :: Segd -> PArray_Bool# -> PArray_Int# +truesPAs_Bool# segd = sumPAs_Int# segd . fromBoolPA# +{-# INLINE truesPAs_Bool# #-} + +fromBoolPA# :: PArray_Bool# -> PArray_Int# +fromBoolPA# = U.map (tagToInt . fromBool) +{-# INLINE_PA fromBoolPA# #-} + +toBoolPA# :: PArray_Int# -> PArray_Bool# +toBoolPA# = U.map (toBool . intToTag) +{-# INLINE_PA toBoolPA# #-} + diff --git a/Data/Array/Parallel/PArr.hs b/Data/Array/Parallel/PArr.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/PArr.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ParallelArrays, UnboxedTuples, MagicHash #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} + +-- #hide +module Data.Array.Parallel.PArr ( + emptyPArr, replicatePArr, singletonPArr, indexPArr, lengthPArr +) where + +import GHC.ST ( ST(..), runST ) +import GHC.Base ( Array#, Int (I#), MutableArray#, newArray#, + unsafeFreezeArray#, indexArray#, {- writeArray# -} ) +import GHC.PArr -- provides the definition of '[::]' + +emptyPArr :: [:a:] +{-# NOINLINE emptyPArr #-} +emptyPArr = replicatePArr 0 undefined + +replicatePArr :: Int -> a -> [:a:] +{-# NOINLINE replicatePArr #-} +replicatePArr n e = runST (do + marr# <- newArray n e + mkPArr n marr#) + +singletonPArr :: a -> [:a:] +{-# NOINLINE singletonPArr #-} +singletonPArr e = replicatePArr 1 e + +indexPArr :: [:e:] -> Int -> e +{-# NOINLINE indexPArr #-} +indexPArr (PArr n arr#) i@(I# i#) + | i >= 0 && i < n = + case indexArray# arr# i# of (# e #) -> e + | otherwise = error $ "indexPArr: out of bounds parallel array index; " ++ + "idx = " ++ show i ++ ", arr len = " + ++ show n + +lengthPArr :: [:a:] -> Int +{-# NOINLINE lengthPArr #-} +lengthPArr (PArr n _) = n + +-- auxiliary functions +-- ------------------- + +-- internally used mutable boxed arrays +-- +data MPArr s e = MPArr !Int (MutableArray# s e) + +-- allocate a new mutable array that is pre-initialised with a given value +-- +newArray :: Int -> e -> ST s (MPArr s e) +{-# INLINE newArray #-} +newArray n@(I# n#) e = ST $ \s1# -> + case newArray# n# e s1# of { (# s2#, marr# #) -> + (# s2#, MPArr n marr# #)} + +-- convert a mutable array into the external parallel array representation +-- +mkPArr :: Int -> MPArr s e -> ST s [:e:] +{-# INLINE mkPArr #-} +mkPArr n (MPArr _ marr#) = ST $ \s1# -> + case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> + (# s2#, PArr n arr# #) } diff --git a/Data/Array/Parallel/PArray.hs b/Data/Array/Parallel/PArray.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/PArray.hs @@ -0,0 +1,245 @@ + +-- | Parallel Arrays. +-- +-- Parallel arrays use a fixed generic representation. All data stored in +-- them is converted to the generic representation, and we have a small +-- number of operators that work on arrays of these generic types. +-- +-- Representation types include Ints, Floats, Tuples and Sums, so arrays of +-- these types can be stored directly. However, user defined algebraic data +-- needs to be converted as we don't have operators that work directly on +-- arrays of these types. +-- +-- The top-level PArray type is built up from several type families and +-- clases: +-- +-- PArray - This is the top level type. It holds an array length, +-- and array data in the generic representation (PData). +-- +-- PRepr - Family of types that can be converted to the generic +-- representation. We supply instances for basic types +-- like Ints Floats etc, but the vectoriser needs to make +-- the instances for user-defined data types itself. +-- PA class - Contains methods to convert to and from the generic +-- representation (PData). +-- +-- PData - Family of types that can be stored directly in parallel +-- arrays. We supply all the PData instances we need here +-- in the library. +-- PR class - Contains methods that work directly on parallel arrays. +-- Most of these are just wrappers for the corresponding +-- U.Array operators. +-- +-- Scalar class - Contains methods to convert between the generic +-- representation (PData) and plain U.Arrays. +-- +-- Note that the PRepr family and PA class are related. +-- so are the PData family and PR class. +-- +-- For motivational material see: +-- "An Approach to Fast Arrays in Haskell", Chakravarty and Keller, 2003 +-- +-- For discussion of how the mapping to generic types works see: +-- "Instant Generics: Fast and Easy", Chakravarty, Ditu and Keller, 2009 +-- +module Data.Array.Parallel.PArray ( + PArray, PA, Random(..), + + -- * Array operators. + length, + empty, + replicate, + singleton, + (!:), + zip, unzip, + pack, + concat, (+:+), + indexed, + slice, + update, + bpermute, + enumFromTo, + + -- * Conversion + fromList, + toList, + fromUArrPA', + + -- * Evaluation + nf +) +where +import Data.Array.Parallel.Lifted.PArray +import Data.Array.Parallel.PArray.PReprInstances () +import Data.Array.Parallel.Lifted.Combinators +import Data.Array.Parallel.Lifted.Scalar +import qualified Data.Array.Parallel.Unlifted as U + +import Data.Array.Parallel.Base ( showsApp ) + +import qualified System.Random as R + +import Prelude hiding ( length, replicate, zip, unzip, enumFromTo, concat ) + +-- NOTE: +-- Most of these functions just export the corresponding "vectorised" +-- function from "Data.Array.Parallel.Lifted.Closure". We don't export +-- higher-order functions like map and filter because the versions +-- from there want closures as their function parameters. +-- +-- Instead, we should probably move the first-order "vectorised" +-- functions from D.A.P.L.Closure into this module, and just define +-- the higher-order and lifted ones there. +-- +-- We still want to export these plain PArray functions to make it easier +-- to convert between vectorised and unvectorised code in benchmarks. +-- + +-- | O(1). An empty array, with no elements. +empty :: PA a => PArray a +{-# INLINE empty #-} +empty = emptyPA + + +-- | O(1). Retrieve a numbered element from an array. +(!:) :: PA a => PArray a -> Int -> a +{-# INLINE (!:) #-} +(!:) = indexPA_v + + +-- | O(1). Yield the length of an array. +length :: PA a => PArray a -> Int +{-# INLINE length #-} +length = lengthPA_v + + +-- | O(n). Produce an array containing copies of a given element. +replicate :: PA a => Int -> a -> PArray a +{-# INLINE replicate #-} +replicate = replicatePA_v + + +-- | O(1). Produce an array containing a single element. +singleton :: PA a => a -> PArray a +{-# INLINE singleton #-} +singleton = singletonPA_v + + +-- | O(1). Takes two arrays and returns an array of corresponding pairs. +-- If one array is short, excess elements of the longer array are +-- discarded. +zip :: (PA a, PA b) => PArray a -> PArray b -> PArray (a,b) +{-# INLINE zip #-} +zip = zipPA_v + + +-- | O(1). Transform an array into an array of the first components, +-- and an array of the second components. +unzip :: (PA a, PA b) => PArray (a,b) -> (PArray a, PArray b) +{-# INLINE unzip #-} +unzip = unzipPA_v + + +-- | Select the elements of an array that have their tag set as True. +-- +-- @ +-- packPA [12, 24, 42, 93] [True, False, False, True] +-- = [24, 42] +-- @ +pack :: PA a => PArray a -> PArray Bool -> PArray a +{-# INLINE pack #-} +pack = packPA_v + + + +-- | Concatenate an array of arrays into a single array. +concat :: PA a => PArray (PArray a) -> PArray a +{-# INLINE concat #-} +concat = concatPA_v + + +-- | Append two arrays +(+:+) :: PA a => PArray a -> PArray a -> PArray a +{-# INLINE (+:+) #-} +(+:+) = appPA_v + + +-- | O(n). Tag each element of an array with its index. +-- +-- @indexed [42, 93, 13] = [(0, 42), (1, 93), (2, 13)]@ +-- +indexed :: PA a => PArray a -> PArray (Int, a) +{-# INLINE indexed #-} +indexed = indexedPA_v + + +-- | Extract a subrange of elements from an array. +-- The first argument is the starting index, while the second is the +-- length of the slice. +-- +slice :: PA a => Int -> Int -> PArray a -> PArray a +{-# INLINE slice #-} +slice = slicePA_v + + +-- | Copy the source array in the destination, using new values for the given indices. +update :: PA a => PArray a -> PArray (Int,a) -> PArray a +{-# INLINE update #-} +update = updatePA_v + + +-- | O(n). Backwards permutation of array elements. +-- +-- @bpermute [50, 60, 20, 30] [0, 3, 2] = [50, 30, 20]@ +-- +bpermute :: PA a => PArray a -> PArray Int -> PArray a +{-# INLINE bpermute #-} +bpermute = bpermutePA_v + + +-- | O(n). Generate a range of @Int@s. +enumFromTo :: Int -> Int -> PArray Int +{-# INLINE enumFromTo #-} +enumFromTo = enumFromToPA_v + + +-- Conversion ----------------------------------------------------------------- +-- | Create a `PArray` from a list. +fromList :: PA a => [a] -> PArray a +{-# INLINE fromList #-} +fromList = fromListPA + +-- | Create a list from a `PArray`. +toList :: PA a => PArray a -> [a] +toList xs = [indexPA_v xs i | i <- [0 .. length xs - 1]] + + +instance (PA a, Show a) => Show (PArray a) where + showsPrec n xs = showsApp n "fromList" (toList xs) + + +-- Evaluation ----------------------------------------------------------------- +-- | Ensure an array is fully evaluated. +nf :: PA a => PArray a -> () +nf = nfPA + + +-- Randoms -------------------------------------------------------------------- +class Random a where + randoms :: R.RandomGen g => Int -> g -> PArray a + randomRs :: R.RandomGen g => Int -> (a, a) -> g -> PArray a + +prim_randoms :: (Scalar a, R.Random a, R.RandomGen g) => Int -> g -> PArray a +prim_randoms n = fromUArrPA' . U.randoms n + +prim_randomRs :: (Scalar a, R.Random a, R.RandomGen g) => Int -> (a, a) -> g -> PArray a +prim_randomRs n r = fromUArrPA' . U.randomRs n r + +instance Random Int where + randoms = prim_randoms + randomRs = prim_randomRs + +instance Random Double where + randoms = prim_randoms + randomRs = prim_randomRs + diff --git a/Data/Array/Parallel/PArray/Base.hs b/Data/Array/Parallel/PArray/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/PArray/Base.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} + +#include "fusion-phases.h" + +-- | Definition of the PArray type, and functions that work on it. The PArray +-- type is a PData with an array length. The functions we export from this +-- module are just wrappers for the PD functions from Data.Array.Parallel.PArray.PRepr. +-- +-- TODO: Check inconsistent use of INLINE pragmas. +-- Most have INLINE_PA, but bpermutePD and nfPD have plain INLINE +-- +module Data.Array.Parallel.PArray.Base ( + PArray(..), + lengthPA#, + dataPA#, + + -- These functions have corresponding members in the PR class + -- from Data.Array.Parallel.PArray.PData. + emptyPA, + replicatePA#, + replicatelPA#, + repeatPA#, + indexPA#, + extractPA#, + bpermutePA#, + appPA#, + applPA#, + packByTagPA#, + combine2PA#, + updatePA#, + fromListPA#, fromListPA, + nfPA, +) +where +import Data.Array.Parallel.Lifted.Unboxed (elementsSegd#) +import Data.Array.Parallel.PArray.PData +import Data.Array.Parallel.PArray.PRepr +import Data.Array.Parallel.Base (Tag) +import qualified Data.Array.Parallel.Unlifted as U +import GHC.Exts (Int#, Int(..), (+#), (*#)) +import SpecConstr + + +-- | Lifted\/bulk parallel arrays +-- This contains the array length, along with the element data. +-- +{-# ANN type PArray NoSpecConstr #-} +data PArray a = PArray Int# (PData a) + + +-- | Take the length field of a PArray. +lengthPA# :: PArray a -> Int# +{-# INLINE_PA lengthPA# #-} +lengthPA# (PArray n# _) = n# + +-- | Take the data field of a PArray. +dataPA# :: PArray a -> PData a +{-# INLINE_PA dataPA# #-} +dataPA# (PArray _ d) = d + + +-- PA Wrappers ---------------------------------------------------------------- +-- These wrappers work on PArrays. As the PArray contains a PData, we can +-- can just pass this to the corresponding PD function from +-- Data.Array.Parallel.PArray.PRepr. However, as a PData doesn't contain +-- the array length, we need to do the length calculations here. +-- +-- Note: There are some more operator# functions that work on PArrays in +-- "Data.Array.Parallel.PArray.DataInstances". The ones there have +-- a similar shape but need to know about the underlying representation +-- constructors. +-- +emptyPA :: PA a => PArray a +{-# INLINE_PA emptyPA #-} +emptyPA + = PArray 0# emptyPD + +replicatePA# :: PA a => Int# -> a -> PArray a +{-# INLINE_PA replicatePA# #-} +replicatePA# n# x + = PArray n# (replicatePD n# x) + +replicatelPA# :: PA a => U.Segd -> PArray a -> PArray a +{-# INLINE_PA replicatelPA# #-} +replicatelPA# segd (PArray _ xs) + = PArray (elementsSegd# segd) (replicatelPD segd xs) + +repeatPA# :: PA a => Int# -> PArray a -> PArray a +{-# INLINE_PA repeatPA# #-} +repeatPA# m# (PArray n# xs) + = PArray (m# *# n#) (repeatPD m# n# xs) + +indexPA# :: PA a => PArray a -> Int# -> a +{-# INLINE_PA indexPA# #-} +indexPA# (PArray _ xs) i# + = indexPD xs i# + +extractPA# :: PA a => PArray a -> Int# -> Int# -> PArray a +{-# INLINE_PA extractPA# #-} +extractPA# (PArray _ xs) i# n# + = PArray n# (extractPD xs i# n#) + +bpermutePA# :: PA a => PArray a -> Int# -> U.Array Int -> PArray a +{-# INLINE bpermutePA# #-} +bpermutePA# (PArray _ xs) n# is + = PArray n# (bpermutePD xs n# is) + +appPA# :: PA a => PArray a -> PArray a -> PArray a +{-# INLINE_PA appPA# #-} +appPA# (PArray m# xs) (PArray n# ys) + = PArray (m# +# n#) (appPD xs ys) + +applPA# :: PA a => U.Segd -> U.Segd -> PArray a -> U.Segd -> PArray a -> PArray a +{-# INLINE_PA applPA# #-} +applPA# segd is (PArray m# xs) js (PArray n# ys) + = PArray (m# +# n#) (applPD segd is xs js ys) + +packByTagPA# :: PA a => PArray a -> Int# -> U.Array Tag -> Int# -> PArray a +{-# INLINE_PA packByTagPA# #-} +packByTagPA# (PArray _ xs) n# tags t# + = PArray n# (packByTagPD xs n# tags t#) + +combine2PA# :: PA a => Int# -> U.Sel2 -> PArray a -> PArray a -> PArray a +{-# INLINE_PA combine2PA# #-} +combine2PA# n# sel (PArray _ as) (PArray _ bs) + = PArray n# (combine2PD n# sel as bs) + +updatePA# :: PA a => PArray a -> U.Array Int -> PArray a -> PArray a +{-# INLINE_PA updatePA# #-} +updatePA# (PArray n# xs) is (PArray _ ys) + = PArray n# (updatePD xs is ys) + +fromListPA# :: PA a => Int# -> [a] -> PArray a +{-# INLINE_PA fromListPA# #-} +fromListPA# n# xs + = PArray n# (fromListPD n# xs) + +fromListPA :: PA a => [a] -> PArray a +{-# INLINE fromListPA #-} +fromListPA xs + = case length xs of + I# n# -> fromListPA# n# xs + +nfPA :: PA a => PArray a -> () +{-# INLINE nfPA #-} +nfPA (PArray _ xs) + = nfPD xs + diff --git a/Data/Array/Parallel/PArray/PData.hs b/Data/Array/Parallel/PArray/PData.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/PArray/PData.hs @@ -0,0 +1,189 @@ +-- | Defines the family of types that store parallel array data, +-- and the operators we can apply to it. +-- +module Data.Array.Parallel.PArray.PData ( + PData, + PR(..), + + -- These types have corresponding members in the PR class. + T_emptyPR, + T_replicatePR, + T_replicatelPR, + T_repeatPR, + T_indexPR, + T_extractPR, + T_bpermutePR, + T_appPR, + T_applPR, + T_packByTagPR, + T_combine2PR, + T_updatePR, + T_fromListPR, + T_nfPR +) +where +import qualified Data.Array.Parallel.Unlifted as U +import Data.Array.Parallel.Base (Tag) +import GHC.Exts (Int#) +import SpecConstr + + +-- | Parallel Data. +-- This is the family of types that store parallel array data. +-- +-- PData takes the type of an element and produces the type we use to store +-- an array of those elements. The instances for PData use an efficient +-- representation that depends on the type of elements being stored. +-- For example, an array of pairs is stored as two separate arrays, one for +-- each element type. This lets us avoid storing the intermediate Pair/Tuple +-- constructors and the pointers to the elements. +-- +-- Most of the instances are defined in "Data.Array.Parallel.PArray.Instances", +-- though the instances for function closures are defined in their own module, +-- "Data.Array.Parallel.Lifted.Closure". +-- +-- Note that PData is just a flat chunk of memory containing elements, and doesn't +-- include a field giving the length of the array. We use PArray when we want to +-- pass around the array data along with its length. +-- +{-# ANN type PData NoSpecConstr #-} +data family PData a + + +-- | A PR dictionary contains the primitive functions that operate directly +-- on parallel array data. +-- +-- It's called PR because the functions work on our internal, efficient +-- Representation of the user-level array. +-- +class PR a where + emptyPR :: T_emptyPR a + replicatePR :: T_replicatePR a + replicatelPR :: T_replicatelPR a + repeatPR :: T_repeatPR a + indexPR :: T_indexPR a + extractPR :: T_extractPR a + bpermutePR :: T_bpermutePR a + appPR :: T_appPR a + applPR :: T_applPR a + packByTagPR :: T_packByTagPR a + combine2PR :: T_combine2PR a + updatePR :: T_updatePR a + fromListPR :: T_fromListPR a + nfPR :: T_nfPR a + + +-- Operator Types ------------------------------------------------------------- +-- | An empty array. +type T_emptyPR a + = PData a + + +-- | Produce an array containing copies of a given element. +type T_replicatePR a + = Int# -- number of copies \/ elements in resulting array + -> a -- element to replicate + -> PData a + + +-- | Segmented replicate. +type T_replicatelPR a + = U.Segd -- segment descriptor of result array + -> PData a + -> PData a + + +-- | Produce an array containing copies of some other array. +type T_repeatPR a + = Int# -- number of times to repeat + -> Int# -- length of source array + -> PData a -- source array + -> PData a + + +-- | Retrieve a numbered element from an array. +type T_indexPR a + = PData a -- source array + -> Int# -- index of desired element + -> a + + +-- | Extract a subrange of elements from an array. +-- +-- extract [:23, 42, 93, 50, 27:] 1 3 = [:42, 93, 50:] +-- +type T_extractPR a + = PData a -- source array + -> Int# -- starting index + -> Int# -- length of result array + -> PData a + + +-- | Construct a new array by selecting elements from a source array. +-- +-- bpermute [:50, 60, 20, 30:] 3 [:0, 3, 2:] = [:50, 30, 20:] +-- +type T_bpermutePR a + = PData a -- source array + -> Int# -- length of resulting array + -> U.Array Int -- indices of elements in source array + -> PData a + + +-- | Append two arrays. +type T_appPR a + = PData a -> PData a -> PData a + + +-- | Segmented append. +type T_applPR a + = U.Segd -- result segd + -> U.Segd -> PData a -- src segd/data 1 + -> U.Segd -> PData a -- src segd/data 2 + -> PData a + + +-- | Select some elements from an array that correspond to a particular tag value +-- and pack them into a new array. +-- +-- packByTag [:23, 42, 95, 50, 27, 49:] 3 [:1, 2, 1, 2, 3, 2:] 2 = [:42, 50, 49:] +-- +type T_packByTagPR a + = PData a -- source array + -> Int# -- length of resulting array + -> U.Array Tag -- tag values of elements in source array + -> Int# -- tag value of the elements to select + -> PData a + + +-- | Combine two arrays based on a selector +-- The selector says which source array to choose for each element of the +-- resulting array. +type T_combine2PR a + = Int# -- length of resulting array + -> U.Sel2 -- selector + -> PData a -- first source array + -> PData a -- second source array + -> PData a + + +-- | Copy an array, but update the values of some of the elements in the result. +type T_updatePR a + = PData a -- source array + -> U.Array Int -- indices of elements to update + -> PData a -- new element values. This array should have the + -- same length as the array of indices + -> PData a + + +-- | Convert a list to an array. +type T_fromListPR a + = Int# -- length of resulting array + -> [a] -- source list + -> PData a + + +-- | Force an array to normal form. +type T_nfPR a + = PData a -> () + diff --git a/Data/Array/Parallel/PArray/PDataInstances.hs b/Data/Array/Parallel/PArray/PDataInstances.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/PArray/PDataInstances.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE CPP, TemplateHaskell, EmptyDataDecls #-} +{-# OPTIONS -fno-warn-orphans -fno-warn-missing-methods #-} + +#include "fusion-phases.h" + +-- | Instances for the PData class +module Data.Array.Parallel.PArray.PDataInstances( + PData(..), + + pvoid, + punit, + + -- * Operators on arrays of tuples + zipPA#, unzipPA#, zip3PA#, + + -- * Operators on nested arrays + segdPA#, concatPA#, segmentPA#, copySegdPA# +) +where +import Data.Array.Parallel.PArray.Base +import Data.Array.Parallel.PArray.PData +import Data.Array.Parallel.PArray.PRepr +import Data.Array.Parallel.PArray.Types +import Data.Array.Parallel.Lifted.TH.Repr +import Data.Array.Parallel.Lifted.Unboxed (elementsSegd#, elementsSel2_0#, elementsSel2_1#) +import Data.Array.Parallel.Base.DTrace (traceFn) +import Data.Array.Parallel.Base (intToTag) +import qualified Data.Array.Parallel.Unlifted as U +import Data.List (unzip4, unzip5) +import GHC.Exts (Int(..), Int#) + + +-- Void ----------------------------------------------------------------------- +-- | The Void type is used when representing enumerations. +-- A type like Bool is represented as @Sum2 Void Void@, meaning that we only +-- only care about the tag of the data constructor and not its argumnent. +-- +data instance PData Void + +pvoid :: PData Void +pvoid = error "Data.Array.Parallel.PData Void" + +$(voidPRInstance ''Void 'void 'pvoid) + + +-- Unit ----------------------------------------------------------------------- +-- | An array of unit values is represented by a single constructor. +-- There is only one possible value, so we only need to record it once. +-- +-- We often uses arrays of unit values as the environmnent portion of a +-- lifted closure. For example, suppose we vectorise the unary function +-- @neg@. This function has no environment, so we construct the closure, +-- we fill in the environment field with @()@, which gives @Clo neg_v neg_l ()@. +-- +-- Suppose we then compute @replicate n neg@. This results in an array of +-- closures. We only need one copy of the implementation functions neg_v and +-- neg_l, but the unit environment () is lifted to an array of units, +-- which we represent as PUnit. +-- +-- Note that we need to store at least one real value, PUnit in this case, +-- because this value also represents the divergence behaviour of the whole +-- array. When evaluating a bulk-strict array, if any of the elements diverge +-- then the whole array does. We represent a diverging array of () by using +-- a diverging computation of type PUnit as its representation. +-- +data instance PData () + = PUnit + +punit :: PData () +punit = PUnit + +$(unitPRInstance 'PUnit) + + +-- Wrap ----------------------------------------------------------------------- +newtype instance PData (Wrap a) + = PWrap (PData a) + +$(wrapPRInstance ''Wrap 'Wrap 'unWrap 'PWrap) + +{- Generated code: +instance PA a => PR (Wrap a) where +... INLINE pragmas ... + emptyPR = traceFn "emptyPR" "Wrap a" (PWrap emptyPD) + + replicatePR n# (Wrap x) + = traceFn "replicatePR" "Wrap a" (PWrap (replicatePD n# x)) + + replicatelPR segd (PWrap xs) + = traceFn "replicatelPR" "Wrap a" (PWrap (replicatelPD segd xs)) + + repeatPR n# len# (PWrap xs) + = traceFn "repeatPR" "Wrap a" (PWrap (repeatPD n# len# xs)) + + indexPR (PWrap xs) i# + = traceFn "indexPR" "Wrap a" (Wrap (indexPD xs i#)) + + extractPR (PWrap xs) i# n# + = traceFn "extractPR" "Wrap a" (PWrap (extractPD xs i# n#)) + + bpermutePR (PWrap xs) n# is + = traceFn "bpermutePR" "Wrap a" (PWrap (bpermutePD xs n# is)) + + appPR (PWrap xs1) (PWrap xs2) + = traceFn "appPR" "Wrap a" (PWrap (appPD xs1 xs2)) + + applPR segd is (PWrap xs1) js (PWrap xs2) + = traceFn "applPR" "Wrap a" (PWrap (applPD segd is xs1 js xs2)) + + packByTagPR (PWrap xs) n# tags t# + = traceFn + "packByTagPR" "Wrap a" (PWrap (packByTagPD xs n# tags t#)) + + combine2PR n# sel (PWrap xs1) (PWrap xs2) + = traceFn "combine2PR" "Wrap a" (PWrap (combine2PD n# sel xs1 xs2)) + + updatePR (PWrap xs1) is (PWrap xs2) + = traceFn "updatePR" "Wrap a" (PWrap (updatePD xs1 is xs2)) + + fromListPR n# xs + = traceFn "fromListPR" "Wrap a" (PWrap (fromListPD n# (map unWrap xs))) + + nfPR (PWrap xs) + = traceFn "nfPR" "Wrap a" (nfPD xs) } +-} + + +-- Tuples --------------------------------------------------------------------- +$(tupleInstances [2..5]) + +{- Generated code: + +data instance PData (a,b) + = P_2 (PData a) + (PData b) + +instance (PR a, PR b) => PR (a,b) where + {-# INLINE emptyPR #-} + emptyPR = P_2 emptyPR emptyPR + + {-# INLINE replicatePR #-} + replicatePR n# (a,b) = + P_2 (replicatePR n# a) + (replicatePR n# b) + + {-# INLINE replicatelPR #-} + replicatelPR segd (P_2 as bs) = + P_2 (replicatelPR segd as) + (replicatelPR segd bs) + + {-# INLINE repeatPR #-} + repeatPR n# len# (P_2 as bs) = + P_2 (repeatPR n# len# as) + (repeatPR n# len# bs) + + {-# INLINE indexPR #-} + indexPR (P_2 as bs) i# = (indexPR as i#, indexPR bs i#) + + {-# INLINE extractPR #-} + extractPR (P_2 as bs) i# n# = + P_2 (extractPR as i# n#) + (extractPR bs i# n#) + + {-# INLINE bpermutePR #-} + bpermutePR (P_2 as bs) n# is = + P_2 (bpermutePR as n# is) + (bpermutePR bs n# is) + + {-# INLINE appPR #-} + appPR (P_2 as1 bs1) (P_2 as2 bs2) = + P_2 (appPR as1 as2) (appPR bs1 bs2) + + {-# INLINE applPR #-} + applPR is (P_2 as1 bs1) js (P_2 as2 bs2) = + P_2 (applPR is as1 js as2) + (applPR is bs1 js bs2) + + {-# INLINE packByTagPR #-} + packByTagPR (P_2 as bs) n# tags t# = + P_2 (packByTagPR as n# tags t#) + (packByTagPR bs n# tags t#) + + {-# INLINE combine2PR #-} + combine2PR n# sel (P_2 as1 bs1) (P_2 as2 bs2) = + P_2 (combine2PR n# sel as1 as2) + (combine2PR n# sel bs1 bs2) + + {-# INLINE updatePR #-} + updatePR (P_2 as1 bs1) is (P_2 as2 bs2) = + P_2 (updatePR as1 is as2) + (updatePR bs1 is bs2) + + {-# INLINE fromListPR #-} + fromListPR n# xs = let (as,bs) = unzip xs in + P_2 (fromListPR n# as) + (fromListPR n# bs) + + {-# INLINE nfPR #-} + nfPR (P_2 as bs) = nfPR as `seq` nfPR bs +-} + + +-- Operators on arrays of tuples. +-- These are here instead of in "Data.Array.Parallel.PArray.Base" because +-- they need to know about the P_2 P_3 constructors. These are the representations +-- of tuple constructors that are generated by $(tupleInstances) above. +zipPA# :: PArray a -> PArray b -> PArray (a ,b) +{-# INLINE_PA zipPA# #-} +zipPA# (PArray n# xs) (PArray _ ys) + = PArray n# (P_2 xs ys) + +unzipPA# :: PArray (a, b) -> (PArray a, PArray b) +{-# INLINE_PA unzipPA# #-} +unzipPA# (PArray n# (P_2 xs ys)) + = (PArray n# xs, PArray n# ys) + + +zip3PA# :: PArray a -> PArray b -> PArray c -> PArray (a, b, c) +{-# INLINE_PA zip3PA# #-} +zip3PA# (PArray n# xs) (PArray _ ys) (PArray _ zs) + = PArray n# (P_3 xs ys zs) + + +-- Sums ----------------------------------------------------------------------- +data instance PData (Sum2 a b) + = PSum2 U.Sel2 (PData a) (PData b) + + +instance (PR a, PR b) => PR (Sum2 a b) where + {-# INLINE emptyPR #-} + emptyPR + = traceFn "emptyPR" "(Sum2 a b)" $ + PSum2 (U.mkSel2 U.empty U.empty 0 0 (U.mkSelRep2 U.empty)) emptyPR emptyPR + + {-# INLINE replicatePR #-} + replicatePR n# (Alt2_1 x) + = traceFn "replicatePR" "(Sum2 a b)" $ + PSum2 (U.mkSel2 (U.replicate (I# n#) 0) + (U.enumFromStepLen 0 1 (I# n#)) + (I# n#) 0 + (U.mkSelRep2 (U.replicate (I# n#) 0))) + (replicatePR n# x) + emptyPR + replicatePR n# (Alt2_2 x) + = traceFn "replicatePR" "(Sum2 a b)" $ + PSum2 (U.mkSel2 (U.replicate (I# n#) 1) + (U.enumFromStepLen 0 1 (I# n#)) + 0 (I# n#) + (U.mkSelRep2 (U.replicate (I# n#) 1))) + emptyPR + (replicatePR n# x) + + {-# INLINE replicatelPR #-} + replicatelPR segd (PSum2 sel as bs) + = traceFn "replicatelPR" "(Sum2 a b)" $ + PSum2 sel' as' bs' + where + tags = U.tagsSel2 sel + tags' = U.replicate_s segd tags + sel' = U.tagsToSel2 tags' + + lens = U.lengthsSegd segd + + asegd = U.lengthsToSegd (U.packByTag lens tags 0) + bsegd = U.lengthsToSegd (U.packByTag lens tags 1) + + as' = replicatelPR asegd as + bs' = replicatelPR bsegd bs + + {-# INLINE repeatPR #-} + repeatPR m# n# (PSum2 sel as bs) + = traceFn "repeatPR" "(Sum2 a b)" $ + PSum2 sel' as' bs' + where + sel' = U.tagsToSel2 + . U.repeat (I# m#) (I# n#) + $ U.tagsSel2 sel + + as' = repeatPR m# (elementsSel2_0# sel) as + bs' = repeatPR n# (elementsSel2_1# sel) bs + + {-# INLINE indexPR #-} + indexPR (PSum2 sel as bs) i# + = traceFn "indexPR" "(Sum2 a b)" $ + case U.indicesSel2 sel U.!: I# i# of + I# k# -> case U.tagsSel2 sel U.!: I# i# of + 0 -> Alt2_1 (indexPR as k#) + _ -> Alt2_2 (indexPR bs k#) + + {-# INLINE appPR #-} + appPR (PSum2 sel1 as1 bs1) + (PSum2 sel2 as2 bs2) + = traceFn "appPR" "(Sum2 a b)" $ + PSum2 sel (appPR as1 as2) + (appPR bs1 bs2) + where + sel = U.tagsToSel2 + $ U.tagsSel2 sel1 U.+:+ U.tagsSel2 sel2 + + {-# INLINE packByTagPR #-} + packByTagPR (PSum2 sel as bs) _ tags t# + = PSum2 sel' as' bs' + where + my_tags = U.tagsSel2 sel + my_tags' = U.packByTag my_tags tags (intToTag (I# t#)) + sel' = U.tagsToSel2 my_tags' + + atags = U.packByTag tags my_tags 0 + btags = U.packByTag tags my_tags 1 + + as' = packByTagPR as (elementsSel2_0# sel') atags t# + bs' = packByTagPR bs (elementsSel2_1# sel') btags t# + + {-# INLINE combine2PR #-} + combine2PR _ sel (PSum2 sel1 as1 bs1) + (PSum2 sel2 as2 bs2) + = traceFn "combine2PR" "(Sum2 a b)" $ + PSum2 sel' as bs + where + tags = U.tagsSel2 sel + tags' = U.combine2 (U.tagsSel2 sel) (U.repSel2 sel) + (U.tagsSel2 sel1) + (U.tagsSel2 sel2) + sel' = U.tagsToSel2 tags' + + asel = U.tagsToSel2 (U.packByTag tags tags' 0) + bsel = U.tagsToSel2 (U.packByTag tags tags' 1) + + as = combine2PR (elementsSel2_0# sel') asel as1 as2 + bs = combine2PR (elementsSel2_1# sel') bsel bs1 bs2 + + +-- Nested Arrays -------------------------------------------------------------- +data instance PData (PArray a) + = PNested U.Segd (PData a) + +instance PR a => PR (PArray a) where + {-# INLINE emptyPR #-} + emptyPR = traceFn "emptyPR" "(PArray a)" $ + PNested (U.mkSegd U.empty U.empty 0) emptyPR + + {-# INLINE replicatePR #-} + replicatePR n# (PArray m# xs) + = traceFn "replicatePR" "(PArray a)" $ + PNested (U.mkSegd (U.replicate (I# n#) (I# m#)) + (U.enumFromStepLen 0 (I# m#) (I# n#)) + (I# n# * I# m#)) + (repeatPR n# m# xs) + + {-# INLINE indexPR #-} + indexPR (PNested segd xs) i# + = traceFn "indexPR" "(PArray a)" $ + case U.lengthsSegd segd U.!: I# i# of { I# n# -> + case U.indicesSegd segd U.!: I# i# of { I# k# -> + PArray n# (extractPR xs k# n#) }} + + {-# INLINE extractPR #-} + extractPR (PNested segd xs) i# n# + = traceFn "extractPR" "(PArray a)" $ + PNested segd' (extractPR xs k# (elementsSegd# segd')) + where + segd' = U.lengthsToSegd + $ U.extract (U.lengthsSegd segd) (I# i#) (I# n#) + + -- NB: not indicesSegd segd !: i because i might be one past the end + !(I# k#) | I# i# == 0 = 0 + | otherwise = U.indicesSegd segd U.!: (I# i# - 1) + + U.lengthsSegd segd U.!: (I# i# - 1) + + {-# INLINE bpermutePR #-} + bpermutePR (PNested segd xs) _ is + = traceFn "bpermutePR" "(PArray a)" $ + PNested segd' (bpermutePR xs (elementsSegd# segd') js) + where + lens' = U.bpermute (U.lengthsSegd segd) is + starts = U.bpermute (U.indicesSegd segd) is + + segd' = U.lengthsToSegd lens' + + js = U.zipWith (+) (U.indices_s segd') + (U.replicate_s segd' starts) + + {-# INLINE appPR #-} + appPR (PNested xsegd xs) (PNested ysegd ys) + = traceFn "appPR" "(PArray a)" $ + PNested (U.lengthsToSegd (U.lengthsSegd xsegd U.+:+ U.lengthsSegd ysegd)) + (appPR xs ys) + + {-# INLINE applPR #-} + applPR rsegd segd1 (PNested xsegd xs) segd2 (PNested ysegd ys) + = traceFn "applPR" "(PArray a)"$ + PNested segd (applPR (U.plusSegd xsegd' ysegd') xsegd' xs ysegd' ys) + where + segd = U.lengthsToSegd + $ U.append_s rsegd segd1 (U.lengthsSegd xsegd) + segd2 (U.lengthsSegd ysegd) + + xsegd' = U.lengthsToSegd + $ U.sum_s segd1 (U.lengthsSegd xsegd) + ysegd' = U.lengthsToSegd + $ U.sum_s segd2 (U.lengthsSegd ysegd) + + {-# INLINE repeatPR #-} + repeatPR n# len# (PNested segd xs) + = traceFn "repeatPR" "(PArray a)" $ + PNested segd' (repeatPR n# (elementsSegd# segd) xs) + where + segd' = U.lengthsToSegd (U.repeat (I# n#) (I# len#) (U.lengthsSegd segd)) + + {-# INLINE replicatelPR #-} + replicatelPR segd (PNested xsegd xs) + = traceFn "replicatelPR" "(PArray a)" $ + PNested xsegd' $ bpermutePR xs (elementsSegd# xsegd') + $ U.enumFromStepLenEach (U.elementsSegd xsegd') + is (U.replicate (U.elementsSegd segd) 1) ns + where + is = U.replicate_s segd (U.indicesSegd xsegd) + ns = U.replicate_s segd (U.lengthsSegd xsegd) + xsegd' = U.lengthsToSegd ns + + {-# INLINE packByTagPR #-} + packByTagPR (PNested segd xs) _ tags t# + = traceFn "packByTagPR" "(PArray a)" $ + PNested segd' xs' + where + segd' = U.lengthsToSegd + $ U.packByTag (U.lengthsSegd segd) tags (intToTag (I# t#)) + + xs' = packByTagPR xs (elementsSegd# segd') (U.replicate_s segd tags) t# + + {-# INLINE combine2PR #-} + combine2PR _ sel (PNested xsegd xs) (PNested ysegd ys) + = traceFn "combine2PR" "(PArray a)" $ + PNested segd xys + where + tags = U.tagsSel2 sel + + segd = U.lengthsToSegd + $ U.combine2 (U.tagsSel2 sel) (U.repSel2 sel) + (U.lengthsSegd xsegd) + (U.lengthsSegd ysegd) + + sel' = U.tagsToSel2 + $ U.replicate_s segd tags + + xys = combine2PR (elementsSegd# segd) sel' xs ys + + +-- Operators on Nested Arrays +-- These are here instead of in "Data.Array.Parallel.PArray.Base" because +-- they need to know about the PNested constructor which is defined above. + +-- | O(1). Extract the segment descriptor from a nested array. +segdPA# :: PArray (PArray a) -> U.Segd +{-# INLINE_PA segdPA# #-} +segdPA# (PArray _ (PNested segd _)) + = segd + + +-- | O(1). Concatenate a nested array. This is a constant time operation as +-- we can just discard the segment descriptor. +concatPA# :: PArray (PArray a) -> PArray a +{-# INLINE_PA concatPA# #-} +concatPA# (PArray _ (PNested segd xs)) + = PArray (elementsSegd# segd) xs + + +-- | O(1). Create a nested array from an element count, segment descriptor, +-- and data elements. +segmentPA# :: Int# -> U.Segd -> PArray a -> PArray (PArray a) +{-# INLINE_PA segmentPA# #-} +segmentPA# n# segd (PArray _ xs) + = PArray n# (PNested segd xs) + + +-- | O(1). Create a nested array by using the element count and segment +-- descriptor from another, but use new data elements. +copySegdPA# :: PArray (PArray a) -> PArray b -> PArray (PArray b) +{-# INLINE copySegdPA# #-} +copySegdPA# (PArray n# (PNested segd _)) (PArray _ xs) + = PArray n# (PNested segd xs) diff --git a/Data/Array/Parallel/PArray/PRepr.hs b/Data/Array/Parallel/PArray/PRepr.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/PArray/PRepr.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} + +#include "fusion-phases.h" + +-- | Defines the family of types that can be represented generically, +-- and the functions to convert two and from the generic representation. +-- +-- TODO: Check inconsistent use of INLINE pragmas. +-- Most have INLINE_PA, but bpermutePD and nfPD have plain INLINE +-- +module Data.Array.Parallel.PArray.PRepr ( + PRepr, + PA(..), + + -- These functions have corresponding members in the PR class + -- from Data.Array.Parallel.PArray.PData. + emptyPD, + replicatePD, + replicatelPD, + repeatPD, + indexPD, + extractPD, + bpermutePD, + appPD, + applPD, + packByTagPD, + combine2PD, + updatePD, + fromListPD, + nfPD +) +where +import Data.Array.Parallel.PArray.PData + + +-- | Representable types. +-- +-- The family of types that we know how to represent generically. +-- PRepr takes an arbitrary type and produces the generic type we use to +-- represent it. +-- +-- Instances for simple types are defined in Data.Array.Parallel.Lifted.Instances. +-- For algebraic types, it's up to the vectoriser/client module to create +-- a suitable instance. +-- +type family PRepr a + + +-- | A PA dictionary contains the functions that we use to convert a +-- representable type to and from its generic representation. +-- The conversion methods should all be O(1). +-- +class PR (PRepr a) => PA a where + toPRepr :: a -> PRepr a + fromPRepr :: PRepr a -> a + toArrPRepr :: PData a -> PData (PRepr a) + fromArrPRepr :: PData (PRepr a) -> PData a + + +-- PD Wrappers ---------------------------------------------------------------- +-- These wrappers work on (PData a) arrays when we know the element type 'a' +-- is representable. For most of them we can just convert the PData to the +-- underlying representation type, and use the corresponding operator from +-- the PR dictionary. +-- +emptyPD :: PA a => T_emptyPR a +{-# INLINE_PA emptyPD #-} +emptyPD + = fromArrPRepr emptyPR + +replicatePD :: PA a => T_replicatePR a +{-# INLINE_PA replicatePD #-} +replicatePD n# x + = fromArrPRepr + . replicatePR n# + $ toPRepr x + +replicatelPD :: PA a => T_replicatelPR a +{-# INLINE_PA replicatelPD #-} +replicatelPD segd xs + = fromArrPRepr + . replicatelPR segd + $ toArrPRepr xs + +repeatPD :: PA a => T_repeatPR a +{-# INLINE_PA repeatPD #-} +repeatPD n# len# xs + = fromArrPRepr + . repeatPR n# len# + $ toArrPRepr xs + +indexPD :: PA a => T_indexPR a +{-# INLINE_PA indexPD #-} +indexPD xs i# + = fromPRepr + $ indexPR (toArrPRepr xs) i# + +extractPD :: PA a => T_extractPR a +{-# INLINE_PA extractPD #-} +extractPD xs i# m# + = fromArrPRepr + $ extractPR (toArrPRepr xs) i# m# + +bpermutePD :: PA a => T_bpermutePR a +{-# INLINE bpermutePD #-} +bpermutePD xs n# is + = fromArrPRepr + $ bpermutePR (toArrPRepr xs) n# is + +appPD :: PA a => T_appPR a +{-# INLINE_PA appPD #-} +appPD xs ys + = fromArrPRepr + $ appPR (toArrPRepr xs) (toArrPRepr ys) + +applPD :: PA a => T_applPR a +{-# INLINE_PA applPD #-} +applPD segd is xs js ys + = fromArrPRepr + $ applPR segd is (toArrPRepr xs) js (toArrPRepr ys) + +packByTagPD :: PA a => T_packByTagPR a +{-# INLINE_PA packByTagPD #-} +packByTagPD xs n# tags t# + = fromArrPRepr + $ packByTagPR (toArrPRepr xs) n# tags t# + +combine2PD :: PA a => T_combine2PR a +{-# INLINE_PA combine2PD #-} +combine2PD n# sel as bs + = fromArrPRepr + $ combine2PR n# sel (toArrPRepr as) (toArrPRepr bs) + +updatePD :: PA a => T_updatePR a +{-# INLINE_PA updatePD #-} +updatePD xs is ys + = fromArrPRepr + $ updatePR (toArrPRepr xs) is (toArrPRepr ys) + +fromListPD :: PA a => T_fromListPR a +{-# INLINE_PA fromListPD #-} +fromListPD n# xs + = fromArrPRepr + $ fromListPR n# (map toPRepr xs) + +nfPD :: PA a => T_nfPR a +{-# INLINE nfPD #-} +nfPD xs = nfPR (toArrPRepr xs) + + diff --git a/Data/Array/Parallel/PArray/PReprInstances.hs b/Data/Array/Parallel/PArray/PReprInstances.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/PArray/PReprInstances.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS -fno-warn-orphans #-} + +#include "fusion-phases.h" + +-- | Instances for the PRepr class. +-- +-- For primitive types these are all trivial, as we represent an array of +-- Ints just as an array of Ints. +-- +-- For algebraic data types defined in the source program, the vectoriser +-- creates the appropriate PRepr instances for those types. +-- +-- Note that polymorphic container types like tuples and arrays use the +-- `Wrap` constructor so we only need to convert one layer of the structure +-- to the generic representation at a time. +-- See "Data.Array.Parallel.PArray.Types" for details. +-- +module Data.Array.Parallel.PArray.PReprInstances where +import Data.Array.Parallel.PArray.PRepr +import Data.Array.Parallel.PArray.PData +import Data.Array.Parallel.PArray.PDataInstances +import Data.Array.Parallel.PArray.Base +import Data.Array.Parallel.PArray.ScalarInstances () +import Data.Array.Parallel.PArray.Types +import qualified Data.Array.Parallel.Unlifted as U +import GHC.Word ( Word8 ) + + +-- Void ----------------------------------------------------------------------- +type instance PRepr Void = Void + +instance PA Void where + toPRepr = id + fromPRepr = id + toArrPRepr = id + fromArrPRepr = id + + +-- Unit ----------------------------------------------------------------------- +type instance PRepr () = () + +instance PA () where + toPRepr = id + fromPRepr = id + toArrPRepr = id + fromArrPRepr = id + + +-- Int ------------------------------------------------------------------------ +type instance PRepr Int = Int + +instance PA Int where + toPRepr = id + fromPRepr = id + toArrPRepr = id + fromArrPRepr = id + + + +-- Word8 ---------------------------------------------------------------------- +type instance PRepr Word8 = Word8 + +instance PA Word8 where + toPRepr = id + fromPRepr = id + toArrPRepr = id + fromArrPRepr = id + + +-- Float ---------------------------------------------------------------------- +type instance PRepr Float = Float + +instance PA Float where + toPRepr = id + fromPRepr = id + toArrPRepr = id + fromArrPRepr = id + + +-- Double --------------------------------------------------------------------- +type instance PRepr Double = Double + +instance PA Double where + toPRepr = id + fromPRepr = id + toArrPRepr = id + fromArrPRepr = id + + +-- Bool ----------------------------------------------------------------------- +data instance PData Bool + = PBool U.Sel2 + +type instance PRepr Bool = Sum2 Void Void + +instance PA Bool where + {-# INLINE toPRepr #-} + toPRepr False = Alt2_1 void + toPRepr True = Alt2_2 void + + {-# INLINE fromPRepr #-} + fromPRepr (Alt2_1 _) = False + fromPRepr (Alt2_2 _) = True + + {-# INLINE toArrPRepr #-} + toArrPRepr (PBool sel) = PSum2 sel pvoid pvoid + + {-# INLINE fromArrPRepr #-} + fromArrPRepr (PSum2 sel _ _) = PBool sel + + +-- Tuple2 --------------------------------------------------------------------- +type instance PRepr (a,b) + = (Wrap a, Wrap b) + +instance (PA a, PA b) => PA (a,b) where + toPRepr (a, b) + = (Wrap a, Wrap b) + + fromPRepr (Wrap a, Wrap b) + = (a, b) + + toArrPRepr (P_2 as bs) + = P_2 (PWrap as) (PWrap bs) + + fromArrPRepr (P_2 (PWrap as) (PWrap bs)) + = P_2 as bs + + +-- Tuple3 --------------------------------------------------------------------- +type instance PRepr (a,b,c) + = (Wrap a, Wrap b, Wrap c) + +instance (PA a, PA b, PA c) => PA (a,b,c) where + toPRepr (a, b, c) + = (Wrap a, Wrap b, Wrap c) + + fromPRepr (Wrap a, Wrap b, Wrap c) + = (a, b, c) + + toArrPRepr (P_3 as bs cs) + = P_3 (PWrap as) (PWrap bs) (PWrap cs) + + fromArrPRepr (P_3 (PWrap as) (PWrap bs) (PWrap cs)) + = P_3 as bs cs + + +-- Tuple4 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d) + = (Wrap a, Wrap b, Wrap c, Wrap d) + +instance (PA a, PA b, PA c, PA d) => PA (a,b,c,d) where + toPRepr (a, b, c, d) + = (Wrap a, Wrap b, Wrap c, Wrap d) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d) + = (a, b, c, d) + + toArrPRepr (P_4 as bs cs ds) + = P_4 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) + + fromArrPRepr (P_4 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds)) + = P_4 as bs cs ds + + +-- Tuple5 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d,e) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e) + +instance (PA a, PA b, PA c, PA d, PA e) => PA (a,b,c,d,e) where + toPRepr (a, b, c, d, e) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e) + = (a, b, c, d, e) + + toArrPRepr (P_5 as bs cs ds es) + = P_5 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) + + fromArrPRepr (P_5 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es)) + = P_5 as bs cs ds es + + +-- PArray --------------------------------------------------------------------- +type instance PRepr (PArray a) + = PArray (PRepr a) + +instance PA a => PA (PArray a) where + {-# INLINE toPRepr #-} + toPRepr (PArray n# xs) + = PArray n# (toArrPRepr xs) + + {-# INLINE fromPRepr #-} + fromPRepr (PArray n# xs) + = PArray n# (fromArrPRepr xs) + + {-# INLINE toArrPRepr #-} + toArrPRepr (PNested segd xs) + = PNested segd (toArrPRepr xs) + + {-# INLINE fromArrPRepr #-} + fromArrPRepr (PNested segd xs) + = PNested segd (fromArrPRepr xs) + diff --git a/Data/Array/Parallel/PArray/Scalar.hs b/Data/Array/Parallel/PArray/Scalar.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/PArray/Scalar.hs @@ -0,0 +1,148 @@ +{-# OPTIONS -fno-warn-orphans #-} +-- | Defines the class of scalar element types, as well as the +-- PData instances for these types. +-- +module Data.Array.Parallel.PArray.Scalar ( + Scalar(..), + + -- These functions have corresponding members in the PR class + -- from Data.Array.Parallel.PArray.PData. + emptyPRScalar, + replicatePRScalar, + replicatelPRScalar, + repeatPRScalar, + indexPRScalar, + extractPRScalar, + bpermutePRScalar, + appPRScalar, + applPRScalar, + packByTagPRScalar, + combine2PRScalar, + updatePRScalar, + fromListPRScalar, + nfPRScalar +) +where +import Data.Array.Parallel.PArray.PData +import Data.Array.Parallel.Base (intToTag, traceF ) +import qualified Data.Array.Parallel.Unlifted as U +import GHC.Exts (Int(..)) + + +-- | Class of scalar types. +-- Scalar types are the ones that we can store in our underlying U.Arrays +-- (which are currently implemented as Data.Vectors). +-- +-- To perform an operation on a PData array of scalar elements, we coerce +-- it to the underling U.Array and use the corresponding U.Array operators. +-- +class U.Elt a => Scalar a where + fromScalarPData :: PData a -> U.Array a + toScalarPData :: U.Array a -> PData a + + +-- Scalar Wrappers ------------------------------------------------------------ +-- These wrappers work on (PData a) arrays when we know the element type 'a' +-- is scalar. For most of them we can just coerce the PData to the underling +-- U.Array and use the corresponding U.Array operator. +-- +-- The underlying U.Array may be processed in parallel or sequentially, +-- depending on what U.Array primitive library has been linked in. +-- +emptyPRScalar :: Scalar a => T_emptyPR a +{-# INLINE emptyPRScalar #-} +emptyPRScalar + = toScalarPData U.empty + +replicatePRScalar :: Scalar a => T_replicatePR a +{-# INLINE replicatePRScalar #-} +replicatePRScalar n# x + = traceF "replicatePRScalar" + $ toScalarPData (U.replicate (I# n#) x) + +replicatelPRScalar :: Scalar a => T_replicatelPR a +{-# INLINE replicatelPRScalar #-} +replicatelPRScalar segd xs + = traceF "replicatelPRScalar" + $ toScalarPData + $ U.replicate_s segd + $ fromScalarPData xs + +repeatPRScalar :: Scalar a => T_repeatPR a +{-# INLINE repeatPRScalar #-} +repeatPRScalar n# len# xs + = traceF "repeatPRScalar" + $ toScalarPData + $ U.repeat (I# n#) (I# len#) + $ fromScalarPData xs + +indexPRScalar :: Scalar a => T_indexPR a +{-# INLINE indexPRScalar #-} +indexPRScalar xs i# + = fromScalarPData xs U.!: I# i# + +extractPRScalar :: Scalar a => T_extractPR a +{-# INLINE extractPRScalar #-} +extractPRScalar xs i# n# + = traceF "extractPRScalar" + $ toScalarPData + $ U.extract (fromScalarPData xs) (I# i#) (I# n#) + +bpermutePRScalar :: Scalar a => T_bpermutePR a +{-# INLINE bpermutePRScalar #-} +bpermutePRScalar xs _ is + = traceF "bpermutePRScalar" + $ toScalarPData + $ U.bpermute (fromScalarPData xs) is + +appPRScalar :: Scalar a => T_appPR a +{-# INLINE appPRScalar #-} +appPRScalar xs ys + = traceF "appPRScalar" + $ toScalarPData + $ fromScalarPData xs U.+:+ fromScalarPData ys + +applPRScalar :: Scalar a => T_applPR a +{-# INLINE applPRScalar #-} +applPRScalar segd xsegd xs ysegd ys + = traceF "applPRScalar" + $ toScalarPData + $ U.append_s segd xsegd (fromScalarPData xs) + ysegd (fromScalarPData ys) + +packByTagPRScalar :: Scalar a => T_packByTagPR a +{-# INLINE packByTagPRScalar #-} +packByTagPRScalar xs _ tags t# + = traceF "packByTagPRScalar" + $ toScalarPData + $ U.packByTag (fromScalarPData xs) + tags + (intToTag (I# t#)) + +combine2PRScalar :: Scalar a => T_combine2PR a +{-# INLINE combine2PRScalar #-} +combine2PRScalar _ sel xs ys + = traceF "combine2PRScalar" + $ toScalarPData + $ U.combine2 (U.tagsSel2 sel) + (U.repSel2 sel) + (fromScalarPData xs) + (fromScalarPData ys) + +updatePRScalar :: Scalar a => T_updatePR a +{-# INLINE updatePRScalar #-} +updatePRScalar xs is ys + = traceF "updatePRScalar" + $ toScalarPData + $ U.update (fromScalarPData xs) + (U.zip is (fromScalarPData ys)) + +fromListPRScalar :: Scalar a => T_fromListPR a +{-# INLINE fromListPRScalar #-} +fromListPRScalar _ xs + = toScalarPData (U.fromList xs) + +nfPRScalar :: Scalar a => T_nfPR a +{-# INLINE nfPRScalar #-} +nfPRScalar xs + = fromScalarPData xs `seq` () diff --git a/Data/Array/Parallel/PArray/ScalarInstances.hs b/Data/Array/Parallel/PArray/ScalarInstances.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/PArray/ScalarInstances.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +#include "fusion-phases.h" + +-- | Instances for the Scalar class. +-- These let us coerce scalar U.Arrays to PData arrays. +module Data.Array.Parallel.PArray.ScalarInstances where +import Data.Array.Parallel.Lifted.TH.Repr +import Data.Array.Parallel.PArray.Scalar +import Data.Array.Parallel.PArray.PData +import GHC.Word ( Word8 ) + + +$(scalarInstances [''Int, ''Float, ''Double, ''Word8]) + +{- Generated code: + newtype instance PData Int = PInt (U.Array Int) + + instance Scalar Int where + fromScalarPData (PInt xs) = xs + toScalarPData = PInt + + instance PR Int where + +-} diff --git a/Data/Array/Parallel/PArray/Types.hs b/Data/Array/Parallel/PArray/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/PArray/Types.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE EmptyDataDecls #-} + +-- | Defines the extra types we use when representing algebraic data in parallel arrays. +-- We don't store values of user defined algebraic type directly in PArrays. Instead, +-- we convert these to a generic representation and store that representation. +-- +-- Conversion to and from the generic representation is handled by the methods +-- of the PA class defined in "Data.Array.Parallel.PArray.PRepr". +-- +--- For further information see: +-- "Instant Generics: Fast and Easy", Chakravarty, Ditu and Keller, 2009 +-- +module Data.Array.Parallel.PArray.Types ( + -- * The Void type + Void, + void, + fromVoid, + + -- * Generic sums + Sum2(..), + Sum3(..), + + -- * The Wrap type + Wrap (..) +) +where + +-- Void ----------------------------------------------------------------------- +-- | The `Void` type is used when representing enumerations. +-- A type like Bool is represented as @Sum2 Void Void@, meaning that we only +-- only care about the tag of the data constructor and not its argumnent. +data Void + +-- | A 'value' with the void type. Used as a placholder like `undefined`. +-- Forcing this yields `error`. +void :: Void +void = error $ unlines + [ "Data.Array.Parallel.PArray.Types.void" + , " With the DPH generic array representation, values of type void" + , " should never be forced. Something has gone badly wrong." ] + + +-- | Coerce a `Void` to a different type. Used as a placeholder like `undefined`. +-- Forcing the result yields `error`. +fromVoid :: a +fromVoid = error $unlines + [ "Data.Array.Parallel.PArray.Types.fromVoid" + , " With the DPH generic array representation, values of type void" + , " should never be forced. Something has gone badly wrong." ] + + +-- Sums ----------------------------------------------------------------------- +-- | Sum types used for the generic representation of algebraic data. +data Sum2 a b = Alt2_1 a | Alt2_2 b +data Sum3 a b c = Alt3_1 a | Alt3_2 b | Alt3_3 c + + +-- Wrap ----------------------------------------------------------------------- +-- | When converting a data type to its generic representation, we use +-- `Wrap` to help us convert only one layer at a time. For example: +-- +-- @ +-- data Foo a = Foo Int a +-- +-- instance PA a => PA (Foo a) where +-- type PRepr (Foo a) = (Int, Wrap a) -- define how (Foo a) is represented +-- @ +-- +-- Here we've converted the @Foo@ data constructor to a pair, and Int +-- is its own representation type. We have PData/PR instances for pairs and +-- Ints, so we can work with arrays of these types. However, we can't just +-- use (Int, a) as the representation of (Foo a) because 'a' might +-- be user defined and we won't have PData/PR instances for it. +-- +-- Instead, we wrap the second element with the Wrap constructor, which tells +-- us that if we want to process this element we still need to convert it +-- to the generic representation (and back). This last part is done by +-- the PR instance of Wrap, who's methods are defined by calls to the *PD +-- functions from "Data.Array.Parallel.PArray.PRepr". +-- +newtype Wrap a = Wrap { unWrap :: a } + + + diff --git a/Data/Array/Parallel/Prelude.hs b/Data/Array/Parallel/Prelude.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Prelude.hs @@ -0,0 +1,22 @@ +-- | This module (as well as the type-specific modules 'Data.Array.Parallel.Prelude.*') are a +-- temporary kludge needed as DPH programs cannot directly use the (non-vectorised) functions from +-- the standard Prelude. It also exports some conversion helpers. +-- +-- /This module should not be explicitly imported in user code anymore./ User code should only +-- import 'Data.Array.Parallel' and, until the vectoriser supports type classes, the type-specific +-- modules 'Data.Array.Parallel.Prelude.*'. + +module Data.Array.Parallel.Prelude ( + module Data.Array.Parallel.Prelude.Bool, + module Data.Array.Parallel.Prelude.Tuple, + + PArray, Scalar(..), + toUArrPA, + fromUArrPA', fromUArrPA_2', fromUArrPA_3, fromUArrPA_3', + nestUSegdPA' +) where + +import Data.Array.Parallel.Prelude.Bool +import Data.Array.Parallel.Prelude.Tuple +import Data.Array.Parallel.Lifted.PArray +import Data.Array.Parallel.Lifted.Scalar diff --git a/Data/Array/Parallel/Prelude/Bool.hs b/Data/Array/Parallel/Prelude/Bool.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Prelude/Bool.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ParallelArrays #-} +{-# OPTIONS_GHC -fvectorise #-} + -- NB: Cannot use any parallel array syntax except the type constructor + +module Data.Array.Parallel.Prelude.Bool ( + Bool(..), + + otherwise, (&&), (||), not, andP, orP, + + -- FIXME: the Simplifier drops these bindings *after* vectorisation if not exported (although, + -- they are referenced in the code generated by the vectoriser) + and_l, or_l, not_l +) where + +import Data.Array.Parallel.VectDepend () -- see Note [Vectoriser dependencies] in the same module + +import Data.Array.Parallel.PArr () +import Data.Array.Parallel.Lifted.Closure +import Data.Array.Parallel.PArray.PReprInstances +import Data.Array.Parallel.Lifted.Scalar +import qualified Data.Array.Parallel.Unlifted as U + +import qualified Prelude as P +import Prelude (Bool(..), otherwise) + -- NB: re-export 'Prelude.otherwise' instead of rolling a new one as the former is special-cased + -- in the Desugarer + +import Data.Bits + +infixr 3 && +infixr 2 || + +(&&) :: Bool -> Bool -> Bool +(&&) = (P.&&) +{-# VECTORISE (&&) = closure2 (P.&&) and_l #-} + +and_l :: PArray Bool -> PArray Bool -> PArray Bool +{-# INLINE and_l #-} +and_l (PArray n# bs) (PArray _ cs) + = PArray n# P.$ + case bs of { PBool sel1 -> + case cs of { PBool sel2 -> + PBool P.$ U.tagsToSel2 (U.zipWith (.&.) (U.tagsSel2 sel1) (U.tagsSel2 sel2)) }} +{-# NOVECTORISE and_l #-} + +(||) :: Bool -> Bool -> Bool +(||) = (P.||) +{-# VECTORISE (||) = closure2 (P.||) or_l #-} + +or_l :: PArray Bool -> PArray Bool -> PArray Bool +{-# INLINE or_l #-} +or_l (PArray n# bs) (PArray _ cs) + = PArray n# P.$ + case bs of { PBool sel1 -> + case cs of { PBool sel2 -> + PBool P.$ U.tagsToSel2 (U.zipWith (.|.) (U.tagsSel2 sel1) (U.tagsSel2 sel2)) }} +{-# NOVECTORISE or_l #-} + +not :: Bool -> Bool +not = P.not +{-# VECTORISE not = closure1 P.not not_l #-} + +not_l :: PArray Bool -> PArray Bool +{-# INLINE not_l #-} +not_l (PArray n# bs) + = PArray n# P.$ + case bs of { PBool sel -> + PBool P.$ U.tagsToSel2 (U.map complement (U.tagsSel2 sel)) } +{-# NOVECTORISE not_l #-} + +andP:: [:Bool:] -> Bool +{-# NOINLINE andP #-} +andP _ = True +{-# VECTORISE andP = closure1 (scalar_fold (&&) True) (scalar_folds (&&) True) #-} + +orP:: [:Bool:] -> Bool +{-# NOINLINE orP #-} +orP _ = True +{-# VECTORISE orP = closure1 (scalar_fold (||) False) (scalar_folds (||) False) #-} diff --git a/Data/Array/Parallel/Prelude/Double.hs b/Data/Array/Parallel/Prelude/Double.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Prelude/Double.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE ParallelArrays #-} +{-# OPTIONS_GHC -fvectorise #-} + -- NB: Cannot use any parallel array syntax except the type constructor + +module Data.Array.Parallel.Prelude.Double ( + Double, + + -- Ord + (==), (/=), (<), (<=), (>), (>=), min, max, + + minimumP, maximumP, minIndexP, maxIndexP, + + -- Num + (+), (-), (*), negate, abs, + + sumP, productP, + + -- Fractional + (/), recip, + + -- Floating + pi, exp, sqrt, log, (**), logBase, + sin, tan, cos, asin, atan, acos, + sinh, tanh, cosh, asinh, atanh, acosh, + + -- RealFrac and similar + fromInt, + + truncate, round, ceiling, floor, +) where + +import Data.Array.Parallel.VectDepend () -- see Note [Vectoriser dependencies] in the same module + +import Data.Array.Parallel.PArr +import Data.Array.Parallel.Lifted.Scalar +import Data.Array.Parallel.Lifted.Closure + +import Prelude (Double, Int, Bool) +import qualified Prelude as P + +infixr 8 ** +infixl 7 *, / +infixl 6 +, - +infix 4 ==, /=, <, <=, >, >= + +(==), (/=), (<), (<=), (>), (>=) :: Double -> Double -> Bool +(==) = (P.==) +{-# VECTORISE SCALAR (==) #-} +(/=) = (P./=) +{-# VECTORISE SCALAR (/=) #-} +(<=) = (P.<=) +{-# VECTORISE SCALAR (<=) #-} +(<) = (P.<) +{-# VECTORISE SCALAR (<) #-} +(>=) = (P.>=) +{-# VECTORISE SCALAR (>=) #-} +(>) = (P.>) +{-# VECTORISE SCALAR (>) #-} + +min, max :: Double -> Double -> Double +min = P.min +{-# VECTORISE SCALAR min #-} +max = P.max +{-# VECTORISE SCALAR max #-} + +minimumP, maximumP :: [:Double:] -> Double +{-# NOINLINE minimumP #-} +minimumP a = a `indexPArr` 0 +{-# VECTORISE minimumP + = closure1 (scalar_fold1 P.min) (scalar_fold1s P.min) :: PArray Double :-> Double #-} +{-# NOINLINE maximumP #-} +maximumP a = a `indexPArr` 0 +{-# VECTORISE maximumP + = closure1 (scalar_fold1 P.max) (scalar_fold1s P.max) :: PArray Double :-> Double #-} + +minIndexP :: [:Double:] -> Int +{-# NOINLINE minIndexP #-} +minIndexP _ = 0 -- FIXME: add proper implementation +{-# VECTORISE minIndexP = minIndexPA #-} + +minIndexPA :: PArray Double :-> Int +{-# INLINE minIndexPA #-} +minIndexPA = closure1 (scalar_fold1Index min') (scalar_fold1sIndex min') +{-# NOVECTORISE minIndexPA #-} + +min' (i,x) (j,y) | x P.<= y = (i,x) + | P.otherwise = (j,y) +{-# NOVECTORISE min' #-} + +maxIndexP :: [:Double:] -> Int +{-# NOINLINE maxIndexP #-} +maxIndexP _ = 0 -- FIXME: add proper implementation +{-# VECTORISE maxIndexP = maxIndexPA #-} + +maxIndexPA :: PArray Double :-> Int +{-# INLINE maxIndexPA #-} +maxIndexPA = closure1 (scalar_fold1Index max') (scalar_fold1sIndex max') +{-# NOVECTORISE maxIndexPA #-} + +max' (i,x) (j,y) | x P.>= y = (i,x) + | P.otherwise = (j,y) +{-# NOVECTORISE max' #-} + +(+), (-), (*) :: Double -> Double -> Double +(+) = (P.+) +{-# VECTORISE SCALAR (+) #-} +(-) = (P.-) +{-# VECTORISE SCALAR (-) #-} +(*) = (P.*) +{-# VECTORISE SCALAR (*) #-} + +negate, abs :: Double -> Double +negate = P.negate +{-# VECTORISE SCALAR negate #-} +abs = P.abs +{-# VECTORISE SCALAR abs #-} + +sumP, productP :: [:Double:] -> Double +{-# NOINLINE sumP #-} +sumP a = a `indexPArr` 0 +{-# VECTORISE sumP + = closure1 (scalar_fold (+) 0) (scalar_folds (+) 0) :: PArray Double :-> Double #-} +{-# NOINLINE productP #-} +productP a = a `indexPArr` 0 +{-# VECTORISE productP + = closure1 (scalar_fold (*) 1) (scalar_folds (*) 1) :: PArray Double :-> Double #-} + +(/) :: Double -> Double -> Double +(/) = (P./) +{-# VECTORISE SCALAR (/) #-} + +recip :: Double -> Double +recip = P.recip +{-# VECTORISE SCALAR recip #-} + +pi :: Double +pi = P.pi +{-# NOVECTORISE pi #-} + +exp, sqrt, log, sin, tan, cos, asin, atan, acos, sinh, tanh, cosh, + asinh, atanh, acosh :: Double -> Double +exp = P.exp +{-# VECTORISE SCALAR exp #-} +sqrt = P.sqrt +{-# VECTORISE SCALAR sqrt #-} +log = P.log +{-# VECTORISE SCALAR log #-} +sin = P.sin +{-# VECTORISE SCALAR sin #-} +tan = P.tan +{-# VECTORISE SCALAR tan #-} +cos = P.cos +{-# VECTORISE SCALAR cos #-} +asin = P.asin +{-# VECTORISE SCALAR asin #-} +atan = P.atan +{-# VECTORISE SCALAR atan #-} +acos = P.acos +{-# VECTORISE SCALAR acos #-} +sinh = P.sinh +{-# VECTORISE SCALAR sinh #-} +tanh = P.tanh +{-# VECTORISE SCALAR tanh #-} +cosh = P.cosh +{-# VECTORISE SCALAR cosh #-} +asinh = P.asinh +{-# VECTORISE SCALAR asinh #-} +atanh = P.atanh +{-# VECTORISE SCALAR atanh #-} +acosh = P.acosh +{-# VECTORISE SCALAR acosh #-} + +(**), logBase :: Double -> Double -> Double +(**) = (P.**) +{-# VECTORISE SCALAR (**) #-} +logBase = P.logBase +{-# VECTORISE SCALAR logBase #-} + +fromInt :: Int -> Double +fromInt = P.fromIntegral +{-# VECTORISE SCALAR fromInt #-} + +truncate, round, ceiling, floor :: Double -> Int +truncate = P.truncate +{-# VECTORISE SCALAR truncate #-} +round = P.round +{-# VECTORISE SCALAR round #-} +ceiling = P.ceiling +{-# VECTORISE SCALAR ceiling #-} +floor = P.floor +{-# VECTORISE SCALAR floor #-} diff --git a/Data/Array/Parallel/Prelude/Float.hs b/Data/Array/Parallel/Prelude/Float.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Prelude/Float.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE ParallelArrays #-} +{-# OPTIONS_GHC -fvectorise #-} + -- NB: Cannot use any parallel array syntax except the type constructor + +module Data.Array.Parallel.Prelude.Float ( + Float, + + -- Ord + (==), (/=), (<), (<=), (>), (>=), min, max, + + minimumP, maximumP, minIndexP, maxIndexP, + + -- Num + (+), (-), (*), negate, abs, + + sumP, productP, + + -- Fractional + (/), recip, + + -- Floating + pi, exp, sqrt, log, (**), logBase, + sin, tan, cos, asin, atan, acos, + sinh, tanh, cosh, asinh, atanh, acosh, + + -- RealFrac and similar + fromInt, + + truncate, round, ceiling, floor, +) where + +import Data.Array.Parallel.VectDepend () -- see Note [Vectoriser dependencies] in the same module + +import Data.Array.Parallel.PArr +import Data.Array.Parallel.Lifted.Scalar +import Data.Array.Parallel.Lifted.Closure + +import Prelude (Float, Int, Bool) +import qualified Prelude as P + +infixr 8 ** +infixl 7 *, / +infixl 6 +, - +infix 4 ==, /=, <, <=, >, >= + +(==), (/=), (<), (<=), (>), (>=) :: Float -> Float -> Bool +(==) = (P.==) +{-# VECTORISE SCALAR (==) #-} +(/=) = (P./=) +{-# VECTORISE SCALAR (/=) #-} +(<=) = (P.<=) +{-# VECTORISE SCALAR (<=) #-} +(<) = (P.<) +{-# VECTORISE SCALAR (<) #-} +(>=) = (P.>=) +{-# VECTORISE SCALAR (>=) #-} +(>) = (P.>) +{-# VECTORISE SCALAR (>) #-} + +min, max :: Float -> Float -> Float +min = P.min +{-# VECTORISE SCALAR min #-} +max = P.max +{-# VECTORISE SCALAR max #-} + +minimumP, maximumP :: [:Float:] -> Float +{-# NOINLINE minimumP #-} +minimumP a = a `indexPArr` 0 +{-# VECTORISE minimumP + = closure1 (scalar_fold1 P.min) (scalar_fold1s P.min) :: PArray Float :-> Float #-} +{-# NOINLINE maximumP #-} +maximumP a = a `indexPArr` 0 +{-# VECTORISE maximumP + = closure1 (scalar_fold1 P.max) (scalar_fold1s P.max) :: PArray Float :-> Float #-} + +minIndexP :: [:Float:] -> Int +{-# NOINLINE minIndexP #-} +minIndexP _ = 0 -- FIXME: add proper implementation +{-# VECTORISE minIndexP = minIndexPA #-} + +minIndexPA :: PArray Float :-> Int +{-# INLINE minIndexPA #-} +minIndexPA = closure1 (scalar_fold1Index min') (scalar_fold1sIndex min') +{-# NOVECTORISE minIndexPA #-} + +min' (i,x) (j,y) | x P.<= y = (i,x) + | P.otherwise = (j,y) +{-# NOVECTORISE min' #-} + +maxIndexP :: [:Float:] -> Int +{-# NOINLINE maxIndexP #-} +maxIndexP _ = 0 -- FIXME: add proper implementation +{-# VECTORISE maxIndexP = maxIndexPA #-} + +maxIndexPA :: PArray Float :-> Int +{-# INLINE maxIndexPA #-} +maxIndexPA = closure1 (scalar_fold1Index max') (scalar_fold1sIndex max') +{-# NOVECTORISE maxIndexPA #-} + +max' (i,x) (j,y) | x P.>= y = (i,x) + | P.otherwise = (j,y) +{-# NOVECTORISE max' #-} + +(+), (-), (*) :: Float -> Float -> Float +(+) = (P.+) +{-# VECTORISE SCALAR (+) #-} +(-) = (P.-) +{-# VECTORISE SCALAR (-) #-} +(*) = (P.*) +{-# VECTORISE SCALAR (*) #-} + +negate, abs :: Float -> Float +negate = P.negate +{-# VECTORISE SCALAR negate #-} +abs = P.abs +{-# VECTORISE SCALAR abs #-} + +sumP, productP :: [:Float:] -> Float +{-# NOINLINE sumP #-} +sumP a = a `indexPArr` 0 +{-# VECTORISE sumP + = closure1 (scalar_fold (+) 0) (scalar_folds (+) 0) :: PArray Float :-> Float #-} +{-# NOINLINE productP #-} +productP a = a `indexPArr` 0 +{-# VECTORISE productP + = closure1 (scalar_fold (*) 1) (scalar_folds (*) 1) :: PArray Float :-> Float #-} + +(/) :: Float -> Float -> Float +(/) = (P./) +{-# VECTORISE SCALAR (/) #-} + +recip :: Float -> Float +recip = P.recip +{-# VECTORISE SCALAR recip #-} + +pi :: Float +pi = P.pi +{-# NOVECTORISE pi #-} + +exp, sqrt, log, sin, tan, cos, asin, atan, acos, sinh, tanh, cosh, + asinh, atanh, acosh :: Float -> Float +exp = P.exp +{-# VECTORISE SCALAR exp #-} +sqrt = P.sqrt +{-# VECTORISE SCALAR sqrt #-} +log = P.log +{-# VECTORISE SCALAR log #-} +sin = P.sin +{-# VECTORISE SCALAR sin #-} +tan = P.tan +{-# VECTORISE SCALAR tan #-} +cos = P.cos +{-# VECTORISE SCALAR cos #-} +asin = P.asin +{-# VECTORISE SCALAR asin #-} +atan = P.atan +{-# VECTORISE SCALAR atan #-} +acos = P.acos +{-# VECTORISE SCALAR acos #-} +sinh = P.sinh +{-# VECTORISE SCALAR sinh #-} +tanh = P.tanh +{-# VECTORISE SCALAR tanh #-} +cosh = P.cosh +{-# VECTORISE SCALAR cosh #-} +asinh = P.asinh +{-# VECTORISE SCALAR asinh #-} +atanh = P.atanh +{-# VECTORISE SCALAR atanh #-} +acosh = P.acosh +{-# VECTORISE SCALAR acosh #-} + +(**), logBase :: Float -> Float -> Float +(**) = (P.**) +{-# VECTORISE SCALAR (**) #-} +logBase = P.logBase +{-# VECTORISE SCALAR logBase #-} + +fromInt :: Int -> Float +fromInt = P.fromIntegral +{-# VECTORISE SCALAR fromInt #-} + +truncate, round, ceiling, floor :: Float -> Int +truncate = P.truncate +{-# VECTORISE SCALAR truncate #-} +round = P.round +{-# VECTORISE SCALAR round #-} +ceiling = P.ceiling +{-# VECTORISE SCALAR ceiling #-} +floor = P.floor +{-# VECTORISE SCALAR floor #-} diff --git a/Data/Array/Parallel/Prelude/Int.hs b/Data/Array/Parallel/Prelude/Int.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Prelude/Int.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE ParallelArrays #-} +{-# OPTIONS_GHC -fvectorise #-} + -- NB: Cannot use any parallel array syntax except the type constructor + +module Data.Array.Parallel.Prelude.Int ( + Int, + + -- Ord + (==), (/=), (<), (<=), (>), (>=), min, max, + + minimumP, maximumP, minIndexP, maxIndexP, + + -- Num + (+), (-), (*), negate, abs, + + sumP, productP, + + -- Integral + div, mod, sqrt, + + -- Enum + enumFromToP +) where + +import Data.Array.Parallel.VectDepend () -- see Note [Vectoriser dependencies] in the same module + +import Data.Array.Parallel.PArr +import Data.Array.Parallel.Lifted.Combinators +import Data.Array.Parallel.Lifted.Scalar +import Data.Array.Parallel.Lifted.Closure + +import Prelude (Int, Bool) +import qualified Prelude as P + +infixl 7 * +infixl 6 +, - +infix 4 ==, /=, <, <=, >, >= +infixl 7 `div`, `mod` + +(==), (/=), (<), (<=), (>), (>=) :: Int -> Int -> Bool +(==) = (P.==) +{-# VECTORISE SCALAR (==) #-} +(/=) = (P./=) +{-# VECTORISE SCALAR (/=) #-} +(<=) = (P.<=) +{-# VECTORISE SCALAR (<=) #-} +(<) = (P.<) +{-# VECTORISE SCALAR (<) #-} +(>=) = (P.>=) +{-# VECTORISE SCALAR (>=) #-} +(>) = (P.>) +{-# VECTORISE SCALAR (>) #-} + +min, max :: Int -> Int -> Int +min = P.min +{-# VECTORISE SCALAR min #-} +max = P.max +{-# VECTORISE SCALAR max #-} + +minimumP, maximumP :: [:Int:] -> Int +{-# NOINLINE minimumP #-} +minimumP a = a `indexPArr` 0 +{-# VECTORISE minimumP + = closure1 (scalar_fold1 P.min) (scalar_fold1s P.min) :: PArray Int :-> Int #-} +{-# NOINLINE maximumP #-} +maximumP a = a `indexPArr` 0 +{-# VECTORISE maximumP + = closure1 (scalar_fold1 P.max) (scalar_fold1s P.max) :: PArray Int :-> Int #-} + +minIndexP :: [:Int:] -> Int +{-# NOINLINE minIndexP #-} +minIndexP _ = 0 -- FIXME: add proper implementation +{-# VECTORISE minIndexP = minIndexPA #-} + +minIndexPA :: PArray Int :-> Int +{-# INLINE minIndexPA #-} +minIndexPA = closure1 (scalar_fold1Index min') (scalar_fold1sIndex min') +{-# NOVECTORISE minIndexPA #-} + +min' (i,x) (j,y) | x P.<= y = (i,x) + | P.otherwise = (j,y) +{-# NOVECTORISE min' #-} + +maxIndexP :: [:Int:] -> Int +{-# NOINLINE maxIndexP #-} +maxIndexP _ = 0 -- FIXME: add proper implementation +{-# VECTORISE maxIndexP = maxIndexPA #-} + +maxIndexPA :: PArray Int :-> Int +{-# INLINE maxIndexPA #-} +maxIndexPA = closure1 (scalar_fold1Index max') (scalar_fold1sIndex max') +{-# NOVECTORISE maxIndexPA #-} + +max' (i,x) (j,y) | x P.>= y = (i,x) + | P.otherwise = (j,y) +{-# NOVECTORISE max' #-} + +(+), (-), (*) :: Int -> Int -> Int +(+) = (P.+) +{-# VECTORISE SCALAR (+) #-} +(-) = (P.-) +{-# VECTORISE SCALAR (-) #-} +(*) = (P.*) +{-# VECTORISE SCALAR (*) #-} + +negate, abs :: Int -> Int +negate = P.negate +{-# VECTORISE SCALAR negate #-} +abs = P.abs +{-# VECTORISE SCALAR abs #-} + +sumP, productP :: [:Int:] -> Int +{-# NOINLINE sumP #-} +sumP a = a `indexPArr` 0 +{-# VECTORISE sumP + = closure1 (scalar_fold (+) 0) (scalar_folds (+) 0) :: PArray Int :-> Int #-} +{-# NOINLINE productP #-} +productP a = a `indexPArr` 0 +{-# VECTORISE productP + = closure1 (scalar_fold (*) 1) (scalar_folds (*) 1) :: PArray Int :-> Int #-} + +div, mod :: Int -> Int -> Int +div = P.div +{-# VECTORISE SCALAR div #-} +mod = P.mod +{-# VECTORISE SCALAR mod #-} + +sqrt :: Int -> Int +sqrt n = P.floor (P.sqrt (P.fromIntegral n) :: P.Double) +{-# VECTORISE SCALAR sqrt #-} + +enumFromToP :: Int -> Int -> [:Int:] +{-# NOINLINE enumFromToP #-} +enumFromToP x y = singletonPArr (x + y) +{-# VECTORISE enumFromToP = enumFromToPA_Int #-} diff --git a/Data/Array/Parallel/Prelude/Tuple.hs b/Data/Array/Parallel/Prelude/Tuple.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Prelude/Tuple.hs @@ -0,0 +1,15 @@ +module Data.Array.Parallel.Prelude.Tuple ( + tup2, tup3 +) where + +import Data.Array.Parallel.Lifted.Closure +import Data.Array.Parallel.Lifted.PArray +import Data.Array.Parallel.PArray.PDataInstances + +tup2 :: (PA a, PA b) => a :-> b :-> (a,b) +{-# INLINE tup2 #-} +tup2 = closure2 (,) zipPA# + +tup3 :: (PA a, PA b, PA c) => a :-> b :-> c :-> (a,b,c) +{-# INLINE tup3 #-} +tup3 = closure3 (,,) zip3PA# diff --git a/Data/Array/Parallel/Prelude/Word8.hs b/Data/Array/Parallel/Prelude/Word8.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Prelude/Word8.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE ParallelArrays #-} +{-# OPTIONS_GHC -fvectorise #-} + -- NB: Cannot use any parallel array syntax except the type constructor + +module Data.Array.Parallel.Prelude.Word8 ( + Word8, + + -- Ord + (==), (/=), (<), (<=), (>), (>=), min, max, + + minimumP, maximumP, minIndexP, maxIndexP, + + -- Num + (+), (-), (*), negate, abs, + + sumP, productP, + + -- Integral + div, mod, sqrt, + + toInt, fromInt +) where + +import Data.Array.Parallel.VectDepend () -- see Note [Vectoriser dependencies] in the same module + +import Data.Array.Parallel.PArr +import Data.Array.Parallel.Lifted.Scalar +import Data.Array.Parallel.Lifted.Closure + +import Prelude (Int, Bool) +import Data.Word (Word8) +import qualified Prelude as P + +infixl 7 * +infixl 6 +, - +infix 4 ==, /=, <, <=, >, >= +infixl 7 `div`, `mod` + +(==), (/=), (<), (<=), (>), (>=) :: Word8 -> Word8 -> Bool +(==) = (P.==) +{-# VECTORISE SCALAR (==) #-} +(/=) = (P./=) +{-# VECTORISE SCALAR (/=) #-} +(<=) = (P.<=) +{-# VECTORISE SCALAR (<=) #-} +(<) = (P.<) +{-# VECTORISE SCALAR (<) #-} +(>=) = (P.>=) +{-# VECTORISE SCALAR (>=) #-} +(>) = (P.>) +{-# VECTORISE SCALAR (>) #-} + +min, max :: Word8 -> Word8 -> Word8 +min = P.min +{-# VECTORISE SCALAR min #-} +max = P.max +{-# VECTORISE SCALAR max #-} + +minimumP, maximumP :: [:Word8:] -> Word8 +{-# NOINLINE minimumP #-} +minimumP a = a `indexPArr` 0 +{-# VECTORISE minimumP + = closure1 (scalar_fold1 P.min) (scalar_fold1s P.min) :: PArray Word8 :-> Word8 #-} +{-# NOINLINE maximumP #-} +maximumP a = a `indexPArr` 0 +{-# VECTORISE maximumP + = closure1 (scalar_fold1 P.max) (scalar_fold1s P.max) :: PArray Word8 :-> Word8 #-} + +minIndexP :: [:Word8:] -> Int +{-# NOINLINE minIndexP #-} +minIndexP _ = 0 -- FIXME: add proper implementation +{-# VECTORISE minIndexP = minIndexPA #-} + +minIndexPA :: PArray Word8 :-> Int +{-# INLINE minIndexPA #-} +minIndexPA = closure1 (scalar_fold1Index min') (scalar_fold1sIndex min') +{-# NOVECTORISE minIndexPA #-} + +min' (i,x) (j,y) | x P.<= y = (i,x) + | P.otherwise = (j,y) +{-# NOVECTORISE min' #-} + +maxIndexP :: [:Word8:] -> Int +{-# NOINLINE maxIndexP #-} +maxIndexP _ = 0 -- FIXME: add proper implementation +{-# VECTORISE maxIndexP = maxIndexPA #-} + +maxIndexPA :: PArray Word8 :-> Int +{-# INLINE maxIndexPA #-} +maxIndexPA = closure1 (scalar_fold1Index max') (scalar_fold1sIndex max') +{-# NOVECTORISE maxIndexPA #-} + +max' (i,x) (j,y) | x P.>= y = (i,x) + | P.otherwise = (j,y) +{-# NOVECTORISE max' #-} + +(+), (-), (*) :: Word8 -> Word8 -> Word8 +(+) = (P.+) +{-# VECTORISE SCALAR (+) #-} +(-) = (P.-) +{-# VECTORISE SCALAR (-) #-} +(*) = (P.*) +{-# VECTORISE SCALAR (*) #-} + +negate, abs :: Word8 -> Word8 +negate = P.negate +{-# VECTORISE SCALAR negate #-} +abs = P.abs +{-# VECTORISE SCALAR abs #-} + +sumP, productP :: [:Word8:] -> Word8 +{-# NOINLINE sumP #-} +sumP a = a `indexPArr` 0 +{-# VECTORISE sumP + = closure1 (scalar_fold (+) 0) (scalar_folds (+) 0) :: PArray Word8 :-> Word8 #-} +{-# NOINLINE productP #-} +productP a = a `indexPArr` 0 +{-# VECTORISE productP + = closure1 (scalar_fold (*) 1) (scalar_folds (*) 1) :: PArray Word8 :-> Word8 #-} + +div, mod :: Word8 -> Word8 -> Word8 +div = P.div +{-# VECTORISE SCALAR div #-} +mod = P.mod +{-# VECTORISE SCALAR mod #-} + +sqrt :: Word8 -> Word8 +sqrt n = P.floor (P.sqrt (P.fromIntegral n) :: P.Double) +{-# VECTORISE SCALAR sqrt #-} + +toInt :: Word8 -> Int +toInt = P.fromIntegral +{-# VECTORISE SCALAR toInt #-} + +fromInt :: Int -> Word8 +fromInt = P.fromIntegral +{-# VECTORISE SCALAR fromInt #-} diff --git a/Data/Array/Parallel/VectDepend.hs b/Data/Array/Parallel/VectDepend.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/VectDepend.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -fvectorise #-} +{-# OPTIONS_HADDOCK hide #-} + +-- Note [Vectoriser dependencies] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Some of the modules in 'dph-common' (and hence, 'dph-seq' and 'dph-par') are being vectorised, +-- whereas some other modules in 'dph-common' define names hardwired into the vectoriser — i.e., +-- the vectoriser panics if those latter modules have not been compiled yet. To avoid build races +-- we need to ensure that all vectoriser dependencies are compiler before any of the vectorised +-- modules is being compiled. +-- +-- The present module imports all vectoriser dependencies and we ensure that those are available +-- in vectorised modules by importing the present module into those vectorised modules. In other +-- words, we turn the indirect module dependencies through the vectoriser into explicit module +-- dependencies, which the dependency tracker of the build system will correctly handle. + +-- #hide +module Data.Array.Parallel.VectDepend () where + +import Data.Array.Parallel.PArray.Base () +import Data.Array.Parallel.PArray.Scalar () +import Data.Array.Parallel.PArray.ScalarInstances () +import Data.Array.Parallel.PArray.PRepr () +import Data.Array.Parallel.PArray.PReprInstances () +import Data.Array.Parallel.PArray.PData () +import Data.Array.Parallel.PArray.PDataInstances () +import Data.Array.Parallel.PArray.Types () +import Data.Array.Parallel.Lifted.Closure () +import Data.Array.Parallel.Lifted.Unboxed () +import Data.Array.Parallel.Lifted.Scalar () +import Data.Array.Parallel.Prelude.Tuple () diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,37 @@ +Copyright (c) 2001-2011, The DPH Team +All rights reserved. + +The DPH Team is: + Manuel M T Chakravarty + Gabriele Keller + Roman Leshchinskiy + Ben Lippmeier + George Roldugin + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- 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. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE 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 +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/dph-seq.cabal b/dph-seq.cabal new file mode 100644 --- /dev/null +++ b/dph-seq.cabal @@ -0,0 +1,68 @@ +Name: dph-seq +Version: 0.5.1.1 +License: BSD3 +License-File: LICENSE +Author: The DPH Team +Maintainer: Ben Lippmeier +Homepage: http://www.haskell.org/haskellwiki/GHC/Data_Parallel_Haskell +Category: Data Structures +Synopsis: Data structures for Nested Data-Parallel Haskell. + +Cabal-Version: >= 1.6 +Build-Type: Simple + +Library + -- This Cabal file gets CPPed, then put in ../dhp_par and ../dph_seq + -- We therefore need to point back at the original location for + -- where to find the sources + + Exposed-Modules: + Data.Array.Parallel + Data.Array.Parallel.Lifted + Data.Array.Parallel.Prelude + Data.Array.Parallel.Prelude.Int + Data.Array.Parallel.Prelude.Word8 + Data.Array.Parallel.Prelude.Float + Data.Array.Parallel.Prelude.Double + Data.Array.Parallel.PArray + + Other-Modules: + Data.Array.Parallel.PArr + Data.Array.Parallel.PArray.Base + Data.Array.Parallel.PArray.Scalar + Data.Array.Parallel.PArray.ScalarInstances + Data.Array.Parallel.PArray.PRepr + Data.Array.Parallel.PArray.PReprInstances + Data.Array.Parallel.PArray.PData + Data.Array.Parallel.PArray.PDataInstances + Data.Array.Parallel.PArray.Types + Data.Array.Parallel.Lifted.PArray + Data.Array.Parallel.Lifted.Unboxed + Data.Array.Parallel.Lifted.Scalar + Data.Array.Parallel.Lifted.TH.Repr + Data.Array.Parallel.Lifted.Closure + Data.Array.Parallel.Lifted.Combinators + Data.Array.Parallel.Prelude.Tuple + Data.Array.Parallel.Prelude.Bool + Data.Array.Parallel.VectDepend + + Exposed: False + + Extensions: TypeFamilies, GADTs, RankNTypes, + BangPatterns, MagicHash, UnboxedTuples, TypeOperators + + GHC-Options: -Odph -funbox-strict-fields -fcpr-off + + Build-Depends: + base == 4.4.*, + ghc == 7.2.*, + array == 0.3.*, + random == 1.0.*, + template-haskell == 2.6.*, + dph-base == 0.5.*, + dph-prim-seq == 0.5.* + + GHC-Options: -fdph-this + + GHC-Options: -package-name dph-seq +