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,892 @@ +{-# LANGUAGE ParallelArrays #-} +{-# OPTIONS_GHC -fvectorise #-} + +-- | User level interface of parallel arrays. +-- +-- This library is deprecated. Using it can result in the vectorised program +-- having asymptotically worse complexity than the original. Your program +-- could be 10000x slower than it should be with this library. +-- +-- Use the @dph-lifted-vseg@ package instead. + +-- +-- /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! +--- +-- 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'. +-- +-- UGLY HACK ALERT: +-- Same ugly hack as in 'base:GHC.PArr'! We could do without in this module by +-- using the type synonym 'PArr' instead of '[::]', but that would lead to +-- significantly worse error message for end users. + +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, zip3P, unzipP, unzip3P, zipWithP, zipWith3P, + {- enumFromToP, enumFromThenToP, -} -- removed until we support type classes + bpermuteP, updateP, indexedP, sliceP, + crossMapP, + + -- * Conversions + PArray, fromPArrayP, toPArrayP, fromNestedPArrayP +) where + +import Data.Array.Parallel.Prim () -- dependency required by the vectoriser + +import Data.Array.Parallel.PArr hiding (PArr) +import Data.Array.Parallel.Prelude +import Data.Array.Parallel.Lifted +import Data.Array.Parallel.Lifted.Combinators + + +infixl 9 !: +infixr 5 +:+ + + +-- Vectorise Prelude.undefined +{-# VECTORISE undefined = undefined_v #-} +undefined_v :: forall a. PA a => a +undefined_v = error "Data.Array.Parallel: undefined vectorised" +{-# NOVECTORISE undefined_v #-} + +-- 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 = indexPArr xss 0 +{-# VECTORISE concatP = concatPA #-} + +mapP :: (a -> b) -> [:a:] -> [:b:] +{-# NOINLINE mapP #-} +mapP !_ !_ = emptyP +{-# 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 !_ !_ = emptyP +{-# VECTORISE zipP = zipPA #-} + +zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] +{-# NOINLINE zip3P #-} +zip3P !_ !_ !_ = emptyP +{-# VECTORISE zip3P = zip3PA #-} + +unzipP :: [:(a, b):] -> ([:a:], [:b:]) +{-# NOINLINE unzipP #-} +unzipP !_ = (emptyP, emptyP) +{-# VECTORISE unzipP = unzipPA #-} + +unzip3P :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) +{-# NOINLINE unzip3P #-} +unzip3P !_ = (emptyP, emptyP, emptyP) +{-# VECTORISE unzip3P = unzip3PA #-} + +zipWithP :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] +{-# NOINLINE zipWithP #-} +zipWithP !_ !_ !_ = emptyP +{-# VECTORISE zipWithP = zipWithPA #-} + +zipWith3P :: (a -> b -> c -> d) -> [:a:] -> [:b:] -> [:c:] -> [:d:] +{-# NOINLINE zipWith3P #-} +zipWith3P !_ !_ !_ !_ = emptyP +{-# VECTORISE zipWith3P = zipWith3PA #-} + +-- 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 !_ = emptyP +{-# 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 !_ !_ = emptyP +{-# 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 + + +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 + +dropP :: Int -> [:a:] -> [:a:] +dropP n a = sliceP n (lengthP a - n) 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,244 @@ +{-# OPTIONS -fno-warn-missing-methods #-} +module Data.Array.Parallel.Lifted.Closure ( + (:->)(..), PArray(..), + mkClosure, mkClosureP, ($:), ($:^), + closure, liftedClosure, liftedApply, + + closure1, closure2, closure3, closure4 +) 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 + +-- | Arity-4 closures. +closure4 :: (PA a, PA b, PA c) + => (a -> b -> c -> d -> e) + -> (PArray a -> PArray b -> PArray c -> PArray d -> PArray e) + -> (a :-> b :-> c :-> d :-> e) + +{-# INLINE closure4 #-} +closure4 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 = mkClosure fv_4 fl_4 (x, y, z) + fl_3 xys zs = case unzipPA# xys of (xs, ys) -> mkClosureP fv_4 fl_4 (zip3PA# xs ys zs) + + fv_4 (x, y, z) v = fv x y z v + fl_4 ps vs = case unzip3PA# ps of (xs, ys, zs) -> fl xs ys zs vs 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,535 @@ +{-# 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, + zipPA, zip3PA, zipWithPA, zipWith3PA, unzipPA, unzip3PA, + 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 = fromUArray' (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 ------------------------------------------------------------------------ +-- |Turns a tuple of arrays into an array of the corresponding tuples. +-- +-- 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)) + + +zip3PA :: (PA a, PA b, PA c) => PArray a :-> PArray b :-> PArray c :-> PArray (a, b, c) +{-# INLINE zip3PA #-} +zip3PA = closure3 zip3PA_v zip3PA_l + +zip3PA_v :: (PA a, PA b, PA c) => PArray a -> PArray b -> PArray c -> PArray (a, b, c) +{-# INLINE_PA zip3PA_v #-} +zip3PA_v xs ys = zip3PA# xs ys + +zip3PA_l :: (PA a, PA b, PA c) + => PArray (PArray a) -> PArray (PArray b) -> PArray (PArray c) -> PArray (PArray (a, b, c)) +{-# INLINE_PA zip3PA_l #-} +zip3PA_l (PArray n# (PNested segd xs)) (PArray _ (PNested _ ys)) (PArray _ (PNested _ zs)) + = PArray n# (PNested segd (P_3 xs ys zs)) + + +-- zipWith -------------------------------------------------------------------- +-- |Map a function over multiple arrays at once. + +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) + + +zipWith3PA :: (PA a, PA b, PA c, PA d) + => (a :-> b :-> c :-> d) :-> PArray a :-> PArray b :-> PArray c :-> PArray d +{-# INLINE zipWith3PA #-} +zipWith3PA = closure4 zipWith3PA_v zipWith3PA_l + +zipWith3PA_v :: (PA a, PA b, PA c, PA d) + => (a :-> b :-> c :-> d) -> PArray a -> PArray b -> PArray c -> PArray d +{-# INLINE_PA zipWith3PA_v #-} +zipWith3PA_v f as bs cs = replicatePA# (lengthPA# as) f $:^ as $:^ bs $:^ cs + +zipWith3PA_l :: (PA a, PA b, PA c, PA d) + => PArray (a :-> b :-> c :-> d) + -> PArray (PArray a) -> PArray (PArray b) -> PArray (PArray c) + -> PArray (PArray d) +{-# INLINE_PA zipWith3PA_l #-} +zipWith3PA_l fs ass bss css + = copySegdPA# ass + (replicatelPA# (segdPA# ass) fs $:^ concatPA# ass $:^ concatPA# bss $:^ concatPA# css) + + +-- unzip ---------------------------------------------------------------------- +-- |Transform an array of tuples into a tuple of arrays. + +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) + +unzip3PA :: (PA a, PA b, PA c) => PArray (a, b, c) :-> (PArray a, PArray b, PArray c) +{-# INLINE unzip3PA #-} +unzip3PA = closure1 unzip3PA_v unzip3PA_l + +unzip3PA_v :: (PA a, PA b, PA c) => PArray (a, b, c) -> (PArray a, PArray b, PArray c) +{-# INLINE_PA unzip3PA_v #-} +unzip3PA_v abs' = unzip3PA# abs' + +unzip3PA_l :: (PA a, PA b) => PArray (PArray (a, b, c)) -> PArray (PArray a, PArray b, PArray c) +{-# INLINE_PA unzip3PA_l #-} +unzip3PA_l xyzss = zip3PA# (copySegdPA# xyzss xs) (copySegdPA# xyzss ys) (copySegdPA# xyzss zs) + where + (xs, ys, zs) = unzip3PA# (concatPA# xyzss) + + +-- 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 (toUArray 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 = fromUArray' (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,210 @@ +{-# 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' +-- +fromUArray :: Scalar a => U.Array a -> PArray a +{-# INLINE fromUArray #-} +fromUArray xs + = let !(I# n#) = U.length xs + in PArray n# (toScalarPData xs) + +-- TODO: Why do we want this version that takes the length explicitly? +-- Is there some fusion issue that requires this? +fromUArray' :: Scalar a => Int -> U.Array a -> PArray a +{-# INLINE fromUArray' #-} +fromUArray' (I# n#) xs + = PArray n# (toScalarPData xs) + + +-- | Convert a PArray back to a plain U.Array. +toUArray :: Scalar a => PArray a -> U.Array a +{-# INLINE toUArray #-} +toUArray (PArray _ xs) = fromScalarPData xs + + +-- Tuple Conversions ---------------------------------------------------------- +-- | Convert an U.Array of pairs to a PArray. +fromUArray2 + :: (Scalar a, Scalar b) + => U.Array (a,b) -> PArray (a,b) +{-# INLINE fromUArray2 #-} +fromUArray2 ps + = let !(I# n#) = U.length ps + (xs, ys) = U.unzip ps + in PArray n# (P_2 (toScalarPData xs) (toScalarPData ys)) + + +-- | Convert a U.Array of triples to a PArray. +fromUArray3 + :: (Scalar a, Scalar b, Scalar c) + => U.Array ((a,b),c) -> PArray (a,b,c) +{-# INLINE fromUArray3 #-} +fromUArray3 ps + = let !(I# n#) = U.length ps + (qs,zs) = U.unzip ps + (xs,ys) = U.unzip qs + in PArray n# (P_3 (toScalarPData xs) + (toScalarPData ys) + (toScalarPData zs)) + + +-- Nesting arrays ------------------------------------------------------------- +-- | O(1). Create a nested array. +nestUSegd + :: U.Segd -- ^ segment descriptor + -> PArray a -- ^ array of data elements. + -> PArray (PArray a) + +{-# INLINE nestUSegd #-} +nestUSegd segd (PArray _ xs) + = let !(I# n#) = U.lengthSegd segd + in PArray n# (PNested 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 + = fromUArray' (prim_lengthPA xs) + . U.map f + $ toUArray 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 + = fromUArray' (prim_lengthPA xs) + $ U.zipWith f (toUArray xs) (toUArray 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 + = fromUArray' (prim_lengthPA xs) + $ U.zipWith3 f (toUArray xs) (toUArray ys) (toUArray 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 . toUArray + + +-- | 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 . toUArray + + +-- | 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 + = fromUArray' (prim_lengthPA (concatPA# xss)) + . U.fold_s f z (segdPA# xss) + . toUArray + $ 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 + = fromUArray' (prim_lengthPA (concatPA# xss)) + . U.fold1_s f (segdPA# xss) + . toUArray + $ 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 . toUArray + + +-- | 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 "ixs"]) + , ('appPR, [(++"1"), (++"2")]) + , ('applPR, [const "segd", const "ixs", (++"1"), const "jxs", (++"2")]) + , ('packByTagPR, [id, const "n#", const "tags", const "t#"]) + , ('combine2PR, [const "n#", const "sel", (++"1"), (++"2")]) + , ('updatePR, [(++"1"), const "ixs", (++"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,450 @@ +{-# 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# + +-- unused +-- 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 U.index "indexPA_Int#" ns (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 U.index "indexPA_Word8#" ds (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 U.index "indexPA_Double#" ds (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,64 @@ +{-# LANGUAGE UnboxedTuples, MagicHash #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} + +-- #hide +module Data.Array.Parallel.PArr ( + PArr, emptyPArr, replicatePArr, singletonPArr, indexPArr, lengthPArr +) where + +import GHC.ST ( ST(..), runST ) +import GHC.Base ( Int (I#), MutableArray#, newArray#, + unsafeFreezeArray#, indexArray#, {- writeArray# -} ) +import GHC.PArr -- provides the definition of '[::]' and 'PArr' + + +emptyPArr :: PArr a +{-# NOINLINE emptyPArr #-} +emptyPArr = replicatePArr 0 undefined + +replicatePArr :: Int -> a -> PArr a +{-# NOINLINE replicatePArr #-} +replicatePArr n e = runST (do + marr# <- newArray n e + mkPArr n marr#) + +singletonPArr :: a -> PArr a +{-# NOINLINE singletonPArr #-} +singletonPArr e = replicatePArr 1 e + +indexPArr :: PArr 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 :: PArr 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 (PArr 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,257 @@ + +-- | 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(..), + + -- * Evaluation + nf, + + -- * Constructors + empty, + singleton, + replicate, + (+:+), + concat, + nestUSegd, + + -- * Projections + length, + (!:), + slice, + + -- * Update + update, + + -- * Pack and Combine + pack, + bpermute, + + -- * Enumerations + enumFromTo, + indexed, + + -- * Tuples + zip, + unzip, + + -- * Conversions + fromList, toList, + fromUArray, toUArray, + fromUArray2, + fromUArray3 +) +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 Data.Array.Parallel.Base.Text +import qualified Data.Array.Parallel.Unlifted as U +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 = fromUArray . U.randoms n + +prim_randomRs :: (Scalar a, R.Random a, R.RandomGen g) => Int -> (a, a) -> g -> PArray a +prim_randomRs n r = fromUArray . 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,193 @@ +-- | 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, PDatas, + 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 + +-- | Fake type family to satisfy the vectoriser interface. +-- We don't define any PR functions for this family, but we need it to satisfy +-- the vectoriser API. +data family PDatas 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,551 @@ +{-# 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(..), PDatas(..), Sels2, + pvoid, + punit, + + -- * Operators on arrays of tuples + zipPA#, unzipPA#, zip3PA#, unzip3PA#, + zip4PA#, zip5PA#, + + -- * 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, unzip6, unzip7) +import GHC.Exts (Int(..), Int#) + +-- Extra unzips ------------ + +-- We need unzips at large tuples (for tuple instances) as the closure environments generated by the +-- vectoriser are tuples whose arity is determined by the number of free variables. + +unzip8 :: [(a,b,c,d,e,f,g,h)] -> ([a],[b],[c],[d],[e],[f],[g],[h]) +unzip8 = foldr (\(a,b,c,d,e,f,g,h) ~(as,bs,cs,ds,es,fs,gs,hs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs,h:hs)) + ([],[],[],[],[],[],[],[]) + +unzip9 :: [(a,b,c,d,e,f,g,h,i)] -> ([a],[b],[c],[d],[e],[f],[g],[h],[i]) +unzip9 = foldr (\(a,b,c,d,e,f,g,h,i) ~(as,bs,cs,ds,es,fs,gs,hs,is) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs,h:hs,i:is)) + ([],[],[],[],[],[],[],[],[]) + +unzip10 :: [(a,b,c,d,e,f,g,h,i,j)] -> ([a],[b],[c],[d],[e],[f],[g],[h],[i],[j]) +unzip10 = foldr (\(a,b,c,d,e,f,g,h,i,j) ~(as,bs,cs,ds,es,fs,gs,hs,is,js) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs,h:hs,i:is,j:js)) + ([],[],[],[],[],[],[],[],[],[]) + +unzip11 :: [(a,b,c,d,e,f,g,h,i,j,k)] -> ([a],[b],[c],[d],[e],[f],[g],[h],[i],[j],[k]) +unzip11 = foldr (\(a,b,c,d,e,f,g,h,i,j,k) ~(as,bs,cs,ds,es,fs,gs,hs,is,js,ks) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs,h:hs,i:is,j:js,k:ks)) + ([],[],[],[],[],[],[],[],[],[],[]) + +unzip12 :: [(a,b,c,d,e,f,g,h,i,j,k,l)] -> ([a],[b],[c],[d],[e],[f],[g],[h],[i],[j],[k],[l]) +unzip12 = foldr (\(a,b,c,d,e,f,g,h,i,j,k,l) ~(as,bs,cs,ds,es,fs,gs,hs,is,js,ks,ls) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs,h:hs,i:is,j:js,k:ks,l:ls)) + ([],[],[],[],[],[],[],[],[],[],[],[]) + +unzip13 :: [(a,b,c,d,e,f,g,h,i,j,k,l,m)] -> ([a],[b],[c],[d],[e],[f],[g],[h],[i],[j],[k],[l],[m]) +unzip13 = foldr (\(a,b,c,d,e,f,g,h,i,j,k,l,m) ~(as,bs,cs,ds,es,fs,gs,hs,is,js,ks,ls,ms) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs,h:hs,i:is,j:js,k:ks,l:ls,m:ms)) + ([],[],[],[],[],[],[],[],[],[],[],[],[]) + +unzip14 :: [(a,b,c,d,e,f,g,h,i,j,k,l,m,n)] + -> ([a],[b],[c],[d],[e],[f],[g],[h],[i],[j],[k],[l],[m],[n]) +unzip14 = foldr (\(a,b,c,d,e,f,g,h,i,j,k,l,m,n) ~(as,bs,cs,ds,es,fs,gs,hs,is,js,ks,ls,ms,ns) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs,h:hs,i:is,j:js,k:ks,l:ls,m:ms,n:ns)) + ([],[],[],[],[],[],[],[],[],[],[],[],[],[]) + +unzip15 :: [(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)] + -> ([a],[b],[c],[d],[e],[f],[g],[h],[i],[j],[k],[l],[m],[n],[o]) +unzip15 = foldr (\(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) ~(as,bs,cs,ds,es,fs,gs,hs,is,js,ks,ls,ms,ns,os) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs,h:hs,i:is,j:js,k:ks,l:ls,m:ms,n:ns,o:os)) + ([],[],[],[],[],[],[],[],[],[],[],[],[],[],[]) + + +-- 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..15]) + +{- 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 +-} + +data instance PDatas (a, b) + = Ps_2 (PDatas a) (PDatas b) + +-- 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) + +unzip3PA# :: PArray (a, b, c) -> (PArray a, PArray b, PArray c) +{-# INLINE_PA unzip3PA# #-} +unzip3PA# (PArray n# (P_3 xs ys zs)) + = (PArray n# xs, PArray n# ys, PArray n# zs) + + +zip4PA# :: PArray a -> PArray b -> PArray c -> PArray d -> PArray (a, b, c, d) +{-# INLINE_PA zip4PA# #-} +zip4PA# (PArray n# xs) (PArray _ ys) (PArray _ zs) (PArray _ as) + = PArray n# (P_4 xs ys zs as) + +zip5PA# :: PArray a -> PArray b -> PArray c -> PArray d -> PArray e -> PArray (a, b, c, d, e) +{-# INLINE_PA zip5PA# #-} +zip5PA# (PArray n# xs) (PArray _ ys) (PArray _ zs) (PArray _ as) (PArray _ bs) + = PArray n# (P_5 xs ys zs as bs) + + +-- Sums ----------------------------------------------------------------------- +data instance PData (Sum2 a b) + = PSum2 U.Sel2 (PData a) (PData b) + +data instance PDatas (Sum2 a b) + = PSums2 Sels2 (PDatas a) (PDatas b) + +type Sels2 = () + +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.index "indexPR[Sum2]" (U.indicesSel2 sel) (I# i#) of + I# k# -> case U.index "indexPR[Sum2]" (U.tagsSel2 sel) (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.index "indexPR[Nested]" (U.lengthsSegd segd) (I# i#) of { I# n# -> + case U.index "indexPR[Nested]" (U.indicesSegd segd) (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.index "extractPR[Nested]" (U.indicesSegd segd) (I# i# - 1) + + U.index "extractPR[Nested]" (U.lengthsSegd segd) (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,156 @@ +{-# 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 + + -- These methods aren't used in this backend, but the vecoriser expects + -- them to be part of the PA class. It will generate instances for them, + -- but they will never be called at runtime. + toArrPReprs :: PDatas a -> PDatas (PRepr a) + fromArrPReprs :: PDatas (PRepr a) -> PDatas 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,421 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS -fno-warn-orphans -fno-warn-missing-methods #-} + +#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 + + +-- Tuple6 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d,e,f) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f) + +instance (PA a, PA b, PA c, PA d, PA e, PA f) => PA (a,b,c,d,e,f) where + toPRepr (a, b, c, d, e, f) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f) + = (a, b, c, d, e, f) + + toArrPRepr (P_6 as bs cs ds es fs) + = P_6 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) + + fromArrPRepr (P_6 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs)) + = P_6 as bs cs ds es fs + + +-- Tuple7 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d,e,f,g) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g) + +instance (PA a, PA b, PA c, PA d, PA e, PA f, PA g) => PA (a,b,c,d,e,f,g) where + toPRepr (a, b, c, d, e, f, g) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g) + = (a, b, c, d, e, f, g) + + toArrPRepr (P_7 as bs cs ds es fs gs) + = P_7 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + + fromArrPRepr (P_7 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs)) + = P_7 as bs cs ds es fs gs + + +-- Tuple8 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d,e,f,g,h) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h) + +instance (PA a, PA b, PA c, PA d, PA e, PA f, PA g, PA h) => PA (a,b,c,d,e,f,g,h) where + toPRepr (a, b, c, d, e, f, g, h) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h) + = (a, b, c, d, e, f, g, h) + + toArrPRepr (P_8 as bs cs ds es fs gs hs) + = P_8 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) + + fromArrPRepr (P_8 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs)) + = P_8 as bs cs ds es fs gs hs + + +-- Tuple9 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d,e,f,g,h,i) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i) + +instance (PA a, PA b, PA c, PA d, PA e, PA f, PA g, PA h, PA i) => PA (a,b,c,d,e,f,g,h,i) where + toPRepr (a, b, c, d, e, f, g, h, i) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i) + = (a, b, c, d, e, f, g, h, i) + + toArrPRepr (P_9 as bs cs ds es fs gs hs is) + = P_9 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) + + fromArrPRepr (P_9 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is)) + = P_9 as bs cs ds es fs gs hs is + + +-- Tuple10 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d,e,f,g,h,i,j) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j) + +instance (PA a, PA b, PA c, PA d, PA e, PA f, PA g, PA h, PA i, PA j) + => PA (a,b,c,d,e,f,g,h,i,j) where + toPRepr (a, b, c, d, e, f, g, h, i, j) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j) + = (a, b, c, d, e, f, g, h, i, j) + + toArrPRepr (P_10 as bs cs ds es fs gs hs is js) + = P_10 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js) + + fromArrPRepr (P_10 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js)) + = P_10 as bs cs ds es fs gs hs is js + + +-- Tuple11 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d,e,f,g,h,i,j,k) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k) + +instance (PA a, PA b, PA c, PA d, PA e, PA f, PA g, PA h, PA i, PA j, PA k) + => PA (a,b,c,d,e,f,g,h,i,j,k) where + toPRepr (a, b, c, d, e, f, g, h, i, j, k) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k) + = (a, b, c, d, e, f, g, h, i, j, k) + + toArrPRepr (P_11 as bs cs ds es fs gs hs is js ks) + = P_11 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js) (PWrap ks) + + fromArrPRepr (P_11 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js) (PWrap ks)) + = P_11 as bs cs ds es fs gs hs is js ks + + +-- Tuple12 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d,e,f,g,h,i,j,k,l) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l) + +instance (PA a, PA b, PA c, PA d, PA e, PA f, PA g, PA h, PA i, PA j, PA k, PA l) + => PA (a,b,c,d,e,f,g,h,i,j,k,l) where + toPRepr (a, b, c, d, e, f, g, h, i, j, k, l) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l) + = (a, b, c, d, e, f, g, h, i, j, k, l) + + toArrPRepr (P_12 as bs cs ds es fs gs hs is js ks ls) + = P_12 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js) (PWrap ks) (PWrap ls) + + fromArrPRepr (P_12 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js) (PWrap ks) (PWrap ls)) + = P_12 as bs cs ds es fs gs hs is js ks ls + + +-- Tuple13 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d,e,f,g,h,i,j,k,l,m) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l, Wrap m) + +instance (PA a, PA b, PA c, PA d, PA e, PA f, PA g, PA h, PA i, PA j, PA k, PA l, PA m) + => PA (a,b,c,d,e,f,g,h,i,j,k,l,m) where + toPRepr (a, b, c, d, e, f, g, h, i, j, k, l, m) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l, Wrap m) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l, Wrap m) + = (a, b, c, d, e, f, g, h, i, j, k, l, m) + + toArrPRepr (P_13 as bs cs ds es fs gs hs is js ks ls ms) + = P_13 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js) (PWrap ks) (PWrap ls) (PWrap ms) + + fromArrPRepr (P_13 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js) (PWrap ks) (PWrap ls) (PWrap ms)) + = P_13 as bs cs ds es fs gs hs is js ks ls ms + + +-- Tuple14 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d,e,f,g,h,i,j,k,l,m,n) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l, Wrap m, Wrap n) + +instance (PA a, PA b, PA c, PA d, PA e, PA f, PA g, PA h, PA i, PA j, PA k, PA l, PA m, PA n) + => PA (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where + toPRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l, Wrap m, Wrap n) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l, Wrap m, Wrap n) + = (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + + toArrPRepr (P_14 as bs cs ds es fs gs hs is js ks ls ms ns) + = P_14 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js) (PWrap ks) (PWrap ls) (PWrap ms) (PWrap ns) + + fromArrPRepr (P_14 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js) (PWrap ks) (PWrap ls) (PWrap ms) (PWrap ns)) + = P_14 as bs cs ds es fs gs hs is js ks ls ms ns + + +-- Tuple15 --------------------------------------------------------------------- +type instance PRepr (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l, Wrap m, Wrap n, Wrap o) + +instance (PA a, PA b, PA c, PA d, PA e, PA f, PA g, PA h, PA i, PA j, PA k, PA l, PA m, PA n, PA o) + => PA (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where + toPRepr (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + = (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l, Wrap m, Wrap n, Wrap o) + + fromPRepr (Wrap a, Wrap b, Wrap c, Wrap d, Wrap e, Wrap f, Wrap g, Wrap h, Wrap i, Wrap j, Wrap k, + Wrap l, Wrap m, Wrap n, Wrap o) + = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + + toArrPRepr (P_15 as bs cs ds es fs gs hs is js ks ls ms ns os) + = P_15 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js) (PWrap ks) (PWrap ls) (PWrap ms) (PWrap ns) + (PWrap os) + + fromArrPRepr (P_15 (PWrap as) (PWrap bs) (PWrap cs) (PWrap ds) (PWrap es) (PWrap fs) (PWrap gs) + (PWrap hs) (PWrap is) (PWrap js) (PWrap ks) (PWrap ls) (PWrap ms) (PWrap ns) + (PWrap os)) + = P_15 as bs cs ds es fs gs hs is js ks ls ms ns os + + +-- 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,149 @@ +{-# 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 +import Data.Array.Parallel.Base.DTrace +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# + = U.index "indexPRScalar" (fromScalarPData xs) (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,13 @@ +-- |This modules bundles all vectorised versions of Prelude definitions. +-- +-- /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.Base, + module Data.Array.Parallel.Prelude.Bool, +) where + +import Data.Array.Parallel.Prelude.Base +import Data.Array.Parallel.Prelude.Bool diff --git a/Data/Array/Parallel/Prelude/Base.hs b/Data/Array/Parallel/Prelude/Base.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Prelude/Base.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -fvectorise #-} + +-- |This module sets up the basic vectorisation map for vectorising the DPH Prelude. + +module Data.Array.Parallel.Prelude.Base + ( PArr + -- , () + , Bool + , Word8, Int + , Float, Double + ) +where + +import Data.Array.Parallel.Prim () -- dependency required by the vectoriser + +import Data.Array.Parallel.PArr +import Data.Array.Parallel.Lifted.Closure + +import Data.Word (Word8) + + +{-# VECTORISE SCALAR type PArr = PArray #-} +{-# VECTORISE SCALAR type PArray = PArray #-} +{-# VECTORISE SCALAR type (->) = (:->) #-} + +{-# VECTORISE type () = () #-} +{-# VECTORISE type Bool = Bool #-} +{-# VECTORISE SCALAR type Word8 #-} +{-# VECTORISE SCALAR type Int #-} +{-# VECTORISE SCALAR type Float #-} +{-# VECTORISE SCALAR type Double #-} 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,95 @@ +{-# OPTIONS_GHC -fvectorise #-} + +module Data.Array.Parallel.Prelude.Bool + ( Bool(..) + + , otherwise, (&&), (||), not, andP, orP + , fromBool, toBool + ) +where + +import Data.Array.Parallel.Prim () -- dependency required by the vectoriser + +import Data.Array.Parallel.Prelude.Base + +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 Data.Bits + + +-- We re-export 'Prelude.otherwise' as is as it is special-cased in the Desugarer + +{-# VECTORISE (&&) = (&&*) #-} +(&&*) :: Bool :-> Bool :-> Bool +{-# INLINE (&&*) #-} +(&&*) = closure2 (&&) and_l +{-# NOVECTORISE (&&*) #-} + +and_l :: PArray Bool -> PArray Bool -> PArray Bool +{-# INLINE and_l #-} +and_l (PArray n# bs) (PArray _ cs) + = PArray n# $ + case bs of { PBool sel1 -> + case cs of { PBool sel2 -> + PBool $ U.tagsToSel2 (U.zipWith (.&.) (U.tagsSel2 sel1) (U.tagsSel2 sel2)) }} +{-# NOVECTORISE and_l #-} + +{-# VECTORISE (||) = (||*) #-} +(||*) :: Bool :-> Bool :-> Bool +{-# INLINE (||*) #-} +(||*) = closure2 (||) or_l +{-# NOVECTORISE (||*) #-} + +or_l :: PArray Bool -> PArray Bool -> PArray Bool +{-# INLINE or_l #-} +or_l (PArray n# bs) (PArray _ cs) + = PArray n# $ + case bs of { PBool sel1 -> + case cs of { PBool sel2 -> + PBool $ U.tagsToSel2 (U.zipWith (.|.) (U.tagsSel2 sel1) (U.tagsSel2 sel2)) }} +{-# NOVECTORISE or_l #-} + +{-# VECTORISE not = not_v #-} +not_v :: Bool :-> Bool +{-# INLINE not_v #-} +not_v = closure1 not not_l +{-# NOVECTORISE not_v #-} + +not_l :: PArray Bool -> PArray Bool +{-# INLINE not_l #-} +not_l (PArray n# bs) + = PArray n# $ + case bs of { PBool sel -> + PBool $ U.tagsToSel2 (U.map complement (U.tagsSel2 sel)) } +{-# NOVECTORISE not_l #-} + +andP:: PArr Bool -> Bool +{-# NOINLINE andP #-} +andP _ = True +{-# VECTORISE andP = andP_v #-} +andP_v :: PArray Bool :-> Bool +{-# INLINE andP_v #-} +andP_v = closure1 (scalar_fold (&&) True) (scalar_folds (&&) True) +{-# NOVECTORISE andP_v #-} + +orP:: PArr Bool -> Bool +{-# NOINLINE orP #-} +orP _ = True +{-# VECTORISE orP = orP_v #-} +orP_v :: PArray Bool :-> Bool +{-# INLINE orP_v #-} +orP_v = closure1 (scalar_fold (||) False) (scalar_folds (||) False) +{-# NOVECTORISE orP_v #-} + +fromBool :: Bool -> Int +fromBool False = 0 +fromBool True = 1 +{-# VECTORISE SCALAR fromBool #-} + +toBool :: Int -> Bool +toBool 0 = False +toBool _ = True +{-# VECTORISE SCALAR toBool #-} 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,204 @@ +{-# OPTIONS_GHC -fvectorise #-} + +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.Prim () -- dependency required by the vectoriser + +import Data.Array.Parallel.Prelude.Base + +import Data.Array.Parallel.PArr +import Data.Array.Parallel.Lifted.Scalar +import Data.Array.Parallel.Lifted.Closure + +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 :: PArr Double -> Double +{-# NOINLINE minimumP #-} +minimumP a = a `indexPArr` 0 +{-# VECTORISE minimumP = minimumP_v #-} +{-# NOINLINE maximumP #-} +maximumP a = a `indexPArr` 0 +{-# VECTORISE maximumP = maximumP_v #-} + +minimumP_v, maximumP_v:: PArray Double :-> Double +{-# INLINE minimumP_v #-} +minimumP_v = closure1 (scalar_fold1 P.min) (scalar_fold1s P.min) +{-# NOVECTORISE minimumP_v #-} +{-# INLINE maximumP_v #-} +maximumP_v = closure1 (scalar_fold1 P.max) (scalar_fold1s P.max) +{-# NOVECTORISE maximumP_v #-} + +minIndexP :: PArr 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 :: PArr 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 :: PArr Double -> Double +{-# NOINLINE sumP #-} +sumP a = a `indexPArr` 0 +{-# VECTORISE sumP = sumP_v #-} +{-# NOINLINE productP #-} +productP a = a `indexPArr` 0 +{-# VECTORISE productP = productP_v #-} + +sumP_v, productP_v:: PArray Double :-> Double +{-# INLINE sumP_v #-} +sumP_v = closure1 (scalar_fold (+) 0) (scalar_folds (+) 0) +{-# NOVECTORISE sumP_v #-} +{-# INLINE productP_v #-} +productP_v = closure1 (scalar_fold (*) 1) (scalar_folds (*) 1) +{-# NOVECTORISE productP_v #-} + +(/) :: 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,204 @@ +{-# OPTIONS_GHC -fvectorise #-} + +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.Prim () -- dependency required by the vectoriser + +import Data.Array.Parallel.Prelude.Base + +import Data.Array.Parallel.PArr +import Data.Array.Parallel.Lifted.Scalar +import Data.Array.Parallel.Lifted.Closure + +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 :: PArr Float -> Float +{-# NOINLINE minimumP #-} +minimumP a = a `indexPArr` 0 +{-# VECTORISE minimumP = minimumP_v #-} +{-# NOINLINE maximumP #-} +maximumP a = a `indexPArr` 0 +{-# VECTORISE maximumP = maximumP_v #-} + +minimumP_v, maximumP_v:: PArray Float :-> Float +{-# INLINE minimumP_v #-} +minimumP_v = closure1 (scalar_fold1 P.min) (scalar_fold1s P.min) +{-# NOVECTORISE minimumP_v #-} +{-# INLINE maximumP_v #-} +maximumP_v = closure1 (scalar_fold1 P.max) (scalar_fold1s P.max) +{-# NOVECTORISE maximumP_v #-} + +minIndexP :: PArr 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 :: PArr 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 :: PArr Float -> Float +{-# NOINLINE sumP #-} +sumP a = a `indexPArr` 0 +{-# VECTORISE sumP = sumP_v #-} +{-# NOINLINE productP #-} +productP a = a `indexPArr` 0 +{-# VECTORISE productP = productP_v #-} + +sumP_v, productP_v:: PArray Float :-> Float +{-# INLINE sumP_v #-} +sumP_v = closure1 (scalar_fold (+) 0) (scalar_folds (+) 0) +{-# NOVECTORISE sumP_v #-} +{-# INLINE productP_v #-} +productP_v = closure1 (scalar_fold (*) 1) (scalar_folds (*) 1) +{-# NOVECTORISE productP_v #-} + +(/) :: 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,148 @@ +{-# OPTIONS_GHC -fvectorise #-} + +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.Prim () -- dependency required by the vectoriser + +import Data.Array.Parallel.Prelude.Base + +import Data.Array.Parallel.PArr +import Data.Array.Parallel.Lifted.Combinators +import Data.Array.Parallel.Lifted.Scalar +import Data.Array.Parallel.Lifted.Closure + +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 :: PArr Int -> Int +{-# NOINLINE minimumP #-} +minimumP a = a `indexPArr` 0 +{-# VECTORISE minimumP = minimumP_v #-} +{-# NOINLINE maximumP #-} +maximumP a = a `indexPArr` 0 +{-# VECTORISE maximumP = maximumP_v #-} + +minimumP_v, maximumP_v:: PArray Int :-> Int +{-# INLINE minimumP_v #-} +minimumP_v = closure1 (scalar_fold1 P.min) (scalar_fold1s P.min) +{-# NOVECTORISE minimumP_v #-} +{-# INLINE maximumP_v #-} +maximumP_v = closure1 (scalar_fold1 P.max) (scalar_fold1s P.max) +{-# NOVECTORISE maximumP_v #-} + +minIndexP :: PArr 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 :: PArr 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 :: PArr Int -> Int +{-# NOINLINE sumP #-} +sumP a = a `indexPArr` 0 +{-# VECTORISE sumP = sumP_v #-} +{-# NOINLINE productP #-} +productP a = a `indexPArr` 0 +{-# VECTORISE productP = productP_v #-} + +sumP_v, productP_v:: PArray Int :-> Int +{-# INLINE sumP_v #-} +sumP_v = closure1 (scalar_fold (P.+) 0) (scalar_folds (P.+) 0) +{-# NOVECTORISE sumP_v #-} +{-# INLINE productP_v #-} +productP_v = closure1 (scalar_fold (P.*) 1) (scalar_folds (P.*) 1) +{-# NOVECTORISE productP_v #-} + +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 -> PArr Int +{-# NOINLINE enumFromToP #-} +enumFromToP x y = singletonPArr (x P.+ 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,19 @@ +module Data.Array.Parallel.Prelude.Tuple ( + tup2, tup3, tup4 +) 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# + +tup4 :: (PA a, PA b, PA c, PA d) => a :-> b :-> c :-> d :-> (a,b,c,d) +{-# INLINE tup4 #-} +tup4 = closure4 (,,,) zip4PA# 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,149 @@ +{-# OPTIONS_GHC -fvectorise #-} + +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.Prim () -- dependency required by the vectoriser + +import Data.Array.Parallel.Prelude.Base + +import Data.Array.Parallel.PArr +import Data.Array.Parallel.Lifted.Scalar +import Data.Array.Parallel.Lifted.Closure + +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 :: PArr Word8 -> Word8 +{-# NOINLINE minimumP #-} +minimumP a = a `indexPArr` 0 +{-# VECTORISE minimumP = minimumP_v #-} +{-# NOINLINE maximumP #-} +maximumP a = a `indexPArr` 0 +{-# VECTORISE maximumP = maximumP_v #-} + +minimumP_v, maximumP_v:: PArray Word8 :-> Word8 +{-# INLINE minimumP_v #-} +minimumP_v = closure1 (scalar_fold1 P.min) (scalar_fold1s P.min) +{-# NOVECTORISE minimumP_v #-} +{-# INLINE maximumP_v #-} +maximumP_v = closure1 (scalar_fold1 P.max) (scalar_fold1s P.max) +{-# NOVECTORISE maximumP_v #-} + +minIndexP :: PArr 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 :: PArr 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 :: PArr Word8 -> Word8 +{-# NOINLINE sumP #-} +sumP a = a `indexPArr` 0 +{-# VECTORISE sumP = sumP_v #-} +{-# NOINLINE productP #-} +productP a = a `indexPArr` 0 +{-# VECTORISE productP = productP_v #-} + +sumP_v, productP_v:: PArray Word8 :-> Word8 +{-# INLINE sumP_v #-} +sumP_v = closure1 (scalar_fold (+) 0) (scalar_folds (+) 0) +{-# NOVECTORISE sumP_v #-} +{-# INLINE productP_v #-} +productP_v = closure1 (scalar_fold (*) 1) (scalar_folds (*) 1) +{-# NOVECTORISE productP_v #-} + +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/Prim.hs b/Data/Array/Parallel/Prim.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Parallel/Prim.hs @@ -0,0 +1,94 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- |This modules defines the interface between the DPH libraries and the compiler. In particular, +-- it exports exactly those definitions that are used by either the desugarer (to remove parallel +-- array syntax) or by the vectoriser (to generate vectorised code). +-- +-- The DPH libraries can evolve between compiler releases as long as this interface remains the +-- same. +-- +-- WARNING: All modules in this package that need to be vectorised (i.e., are compiled with +-- '-fvectorise' must directly or indirectly import this module). This is to ensure that +-- the build system does not attempt to compile a vectorised module before all definitions +-- that are required by the vectoriser are available. + +-- #hide +module Data.Array.Parallel.Prim ( + PData, PDatas(..), PRepr, PA(..), PR(..), + replicatePD, emptyPD, packByTagPD, combine2PD, + Scalar(..), + scalar_map, scalar_zipWith, scalar_zipWith3, + Void, Sum2(..), Sum3(..), Wrap(..), + void, fromVoid, pvoid, pvoids#, punit, + (:->)(..), + closure, liftedClosure, ($:), liftedApply, closure1, closure2, closure3, + Sel2, replicateSel2#, tagsSel2, elementsSel2_0#, elementsSel2_1#, + Sels2, lengthSels2#, + replicatePA_Int#, replicatePA_Double#, + emptyPA_Int#, emptyPA_Double#, + packByTagPA_Int#, packByTagPA_Double#, + combine2PA_Int#, combine2PA_Double#, + + tup2, tup3, tup4, tup5 +) where + +-- We use explicit import lists here to make the vectoriser interface explicit and keep it under +-- tight control. +-- +import Data.Array.Parallel.PArray.Scalar (Scalar(..)) +import Data.Array.Parallel.PArray.ScalarInstances ( {-we require instances-} ) +import Data.Array.Parallel.PArray.PRepr (PRepr, PA(..), replicatePD, emptyPD, packByTagPD, + combine2PD) +import Data.Array.Parallel.PArray.Types (Void, Sum2(..), Sum3(..), Wrap(..), void, + fromVoid) +import Data.Array.Parallel.PArray.PReprInstances ( {-we required instances-} ) +import Data.Array.Parallel.PArray.PData (PData, PDatas, PR(..)) +import Data.Array.Parallel.PArray.PDataInstances (pvoid, punit, Sels2) +import Data.Array.Parallel.Lifted.Closure ((:->)(..), closure, liftedClosure, ($:), + liftedApply, closure1, closure2, closure3) +import Data.Array.Parallel.Lifted.Unboxed (Sel2, replicateSel2#, tagsSel2, elementsSel2_0#, + elementsSel2_1#, + replicatePA_Int#, replicatePA_Double#, + emptyPA_Int#, emptyPA_Double#, + {- packByTagPA_Int#, packByTagPA_Double# -} + combine2PA_Int#, combine2PA_Double#) +import Data.Array.Parallel.Lifted.Scalar (scalar_map, scalar_zipWith, scalar_zipWith3) +import Data.Array.Parallel.Prelude.Tuple (tup2, tup3, tup4) +import GHC.Exts + +packByTagPA_Int#, packByTagPA_Double# :: a +packByTagPA_Int# = error "Data.Array.Parallel.Prim: 'packByTagPA_Int#' not implemented" +packByTagPA_Double# = error "Data.Array.Parallel.Prim: 'packByTagPA_Double#' not implemented" + + + +-- Fake definitions involving PDatas. +-- The dph-lifted-copy backend doesn't used PDatas, but we need to define +-- this stuff as the vectoriser expects it to be here. +-- The vectoriser will generate instances of the PA dictionary involving +-- PDatas, but this backend will never call those methods. +pvoids# :: Int# -> PDatas Void +pvoids# = error "Data.Array.Parallel.Prim.voids: not used in this backend" + +lengthSels2# :: Sels2 -> Int# +lengthSels2# _ = 0# + + +tup5 :: (PA a, PA b, PA c, PA d) + => a :-> b :-> c :-> d :-> e :-> (a, b, c, d, e) +tup5 = error "Data.Array.Paralle.Prim.tup5: not used in this backend" + + +data instance PDatas (a, b, c) + = PTuple3s (PDatas a) (PDatas b) (PDatas c) + +data instance PDatas (a, b, c, d) + = PTuple4s (PDatas a) (PDatas b) (PDatas c) (PDatas d) + +data instance PDatas (a, b, c, d, e) + = PTuple5s (PDatas a) (PDatas b) (PDatas c) (PDatas d) (PDatas e) + +newtype instance PDatas (Wrap a) + = PWraps (PDatas a) + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,36 @@ +Copyright (c) 2001-2012, The DPH Team + +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-lifted-copy.cabal b/dph-lifted-copy.cabal new file mode 100644 --- /dev/null +++ b/dph-lifted-copy.cabal @@ -0,0 +1,74 @@ +Name: dph-lifted-copy +Version: 0.6.0.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 Parallel Haskell lifted array combinators. (deprecated version) +Description: Using this package can cause the vectorised program to have worse + asymptotic complexity than the original. + Use dph-lifted-vseg instead. + This package provides the following: + nested arrays and the primitive operators that work on them (PA functions); + the lifted array combinators that the vectoriser introduces (PP functions); + the user facing library functions that work on [::] style arrays (P functions). + Deprecated implementation that performs deep copying replicate. + + + +Cabal-Version: >= 1.6 +Build-Type: Simple + +Library + Exposed-Modules: + Data.Array.Parallel + Data.Array.Parallel.Lifted + Data.Array.Parallel.Prelude + Data.Array.Parallel.Prelude.Bool + Data.Array.Parallel.Prelude.Int + Data.Array.Parallel.Prelude.Word8 + Data.Array.Parallel.Prelude.Float + Data.Array.Parallel.Prelude.Double + Data.Array.Parallel.PArray + Data.Array.Parallel.Prim + + 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.Base + Data.Array.Parallel.Prelude.Tuple + + Exposed: False + + Extensions: TypeFamilies, GADTs, RankNTypes, + BangPatterns, MagicHash, UnboxedTuples, TypeOperators + + GHC-Options: + -Odph -funbox-strict-fields -fcpr-off + -fno-warn-orphans + -fno-warn-missing-signatures + + Build-Depends: + base == 4.5.*, + ghc == 7.*, + array == 0.4.*, + random == 1.0.*, + template-haskell == 2.7.*, + dph-base == 0.6.*, + dph-prim-par == 0.6.*, + vector == 0.9.*