From: Manuel M T Chakravarty Date: Fri, 18 Feb 2011 01:29:52 +0000 (+0000) Subject: Remove most of GHC.PArr X-Git-Url: http://git.megacz.com/?p=ghc-base.git;a=commitdiff_plain;h=4340cca857b359e16e1d290d824260a57248915d Remove most of GHC.PArr - First step of migrating this code into the dph package --- diff --git a/GHC/PArr.hs b/GHC/PArr.hs index 6a5328f..e337eec 100644 --- a/GHC/PArr.hs +++ b/GHC/PArr.hs @@ -1,6 +1,4 @@ {-# LANGUAGE CPP, ParallelArrays, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- -- | @@ -12,137 +10,11 @@ -- Stability : internal -- Portability : non-portable (GHC Extensions) -- --- Basic implementation of Parallel Arrays. --- --- This module has two functions: (1) It defines the interface to the --- parallel array extension of the Prelude and (2) it provides a vanilla --- implementation of parallel arrays that does not require to flatten the --- array code. The implementation is not very optimised. --- ---- DOCU ---------------------------------------------------------------------- --- --- Language: Haskell 98 plus unboxed values and parallel arrays --- --- The semantic difference between standard Haskell arrays (aka "lazy --- arrays") and parallel arrays (aka "strict arrays") is that the evaluation --- of two different elements of a lazy array is independent, whereas in a --- strict array either non or all elements are evaluated. In other words, --- when a parallel array is evaluated to WHNF, all its elements will be --- evaluated to WHNF. The name parallel array indicates that all array --- elements may, in general, be evaluated to WHNF in parallel without any --- need to resort to speculative evaluation. This parallel evaluation --- semantics is also beneficial in the sequential case, as it facilitates --- loop-based array processing as known from classic array-based languages, --- such as Fortran. --- --- The interface of this module is essentially a variant of the list --- component of the Prelude, but also includes some functions (such as --- permutations) that are not provided for lists. The following list --- operations are not supported on parallel arrays, as they would require the --- availability of infinite parallel arrays: `iterate', `repeat', and `cycle'. --- --- The current implementation is quite simple and entirely based on boxed --- arrays. One disadvantage of boxed arrays is that they require to --- immediately initialise all newly allocated arrays with an error thunk to --- keep the garbage collector happy, even if it is guaranteed that the array --- is fully initialised with different values before passing over the --- user-visible interface boundary. Currently, no effort is made to use --- raw memory copy operations to speed things up. --- ---- TODO ---------------------------------------------------------------------- --- --- * We probably want a standard library `PArray' in addition to the prelude --- extension in the same way as the standard library `List' complements the --- list functions from the prelude. --- --- * Currently, functions that emphasis the constructor-based definition of --- lists (such as, head, last, tail, and init) are not supported. --- --- Is it worthwhile to support the string processing functions lines, --- words, unlines, and unwords? (Currently, they are not implemented.) --- --- It can, however, be argued that it would be worthwhile to include them --- for completeness' sake; maybe only in the standard library `PArray'. --- --- * Prescans are often more useful for array programming than scans. Shall --- we include them into the Prelude or the library? --- --- * Due to the use of the iterator `loop', we could define some fusion rules --- in this module. --- --- * We might want to add bounds checks that can be deactivated. --- +-- !!!THIS FILE IS ABOUT TO GO AWAY!!! 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:] + -- [::] -- Built-in syntax + emptyPArr, replicatePArr, singletonPArr, indexPArr, lengthPArr ) where #ifndef __HADDOCK__ @@ -151,11 +23,7 @@ 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` + unsafeFreezeArray#, indexArray#, {- writeArray#, -} (<#), (>=#) ) -- representation of parallel arrays @@ -169,413 +37,32 @@ infix 4 `elemP`, `notElemP` -- data [::] e = PArr Int# (Array# e) +emptyPArr :: [:a:] +{-# NOINLINE emptyPArr #-} +emptyPArr = replicatePArr 0 undefined --- 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 +replicatePArr :: Int -> a -> [:a:] +{-# NOINLINE replicatePArr #-} +replicatePArr n e = runST (do marr# <- newArray n e mkPArr n marr#) --- cycle -- parallel arrays must be finite - -takeP :: Int -> [:a:] -> [:a:] -takeP n = sliceP 0 (n - 1) - -dropP :: Int -> [:a:] -> [:a:] -dropP n a = sliceP n (lengthP a - 1) a - -splitAtP :: Int -> [:a:] -> ([:a:],[:a:]) -splitAtP n xs = (takeP n xs, dropP n xs) - -takeWhileP :: (a -> Bool) -> [:a:] -> [:a:] -takeWhileP = error "Prelude.takeWhileP: not implemented yet" -- FIXME - -dropWhileP :: (a -> Bool) -> [:a:] -> [:a:] -dropWhileP = error "Prelude.dropWhileP: not implemented yet" -- FIXME - -spanP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) -spanP = error "Prelude.spanP: not implemented yet" -- FIXME - -breakP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) -breakP p = spanP (not . p) - --- lines, words, unlines, unwords, -- is string processing really needed - -reverseP :: [:a:] -> [:a:] -reverseP a = permuteP (enumFromThenToP (len - 1) (len - 2) 0) a - -- we can't use the [:x, y..z:] form here for tedious - -- reasons to do with the typechecker and the fact that - -- `enumFromThenToP' is defined in the same module - where - len = lengthP a - -andP :: [:Bool:] -> Bool -andP = foldP (&&) True - -orP :: [:Bool:] -> Bool -orP = foldP (||) True - -anyP :: (a -> Bool) -> [:a:] -> Bool -anyP p = orP . mapP p - -allP :: (a -> Bool) -> [:a:] -> Bool -allP p = andP . mapP p - -elemP :: (Eq a) => a -> [:a:] -> Bool -elemP x = anyP (== x) - -notElemP :: (Eq a) => a -> [:a:] -> Bool -notElemP x = allP (/= x) - -lookupP :: (Eq a) => a -> [:(a, b):] -> Maybe b -lookupP = error "Prelude.lookupP: not implemented yet" -- FIXME - -sumP :: (Num a) => [:a:] -> a -sumP = foldP (+) 0 - -productP :: (Num a) => [:a:] -> a -productP = foldP (*) 1 - -maximumP :: (Ord a) => [:a:] -> a -maximumP [::] = error "Prelude.maximumP: empty parallel array" -maximumP xs = fold1P max xs - -minimumP :: (Ord a) => [:a:] -> a -minimumP [::] = error "Prelude.minimumP: empty parallel array" -minimumP xs = fold1P min xs - -zipP :: [:a:] -> [:b:] -> [:(a, b):] -zipP = zipWithP (,) - -zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] -zip3P = zipWith3P (,,) - -zipWithP :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] -zipWithP f a1 a2 = let - len1 = lengthP a1 - len2 = lengthP a2 - len = len1 `min` len2 - in - fst $ loopFromTo 0 (len - 1) combine 0 a1 - where - combine e1 i = (Just $ f e1 (a2!:i), i + 1) - -zipWith3P :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:] -zipWith3P f a1 a2 a3 = let - len1 = lengthP a1 - len2 = lengthP a2 - len3 = lengthP a3 - len = len1 `min` len2 `min` len3 - in - fst $ loopFromTo 0 (len - 1) combine 0 a1 - where - combine e1 i = (Just $ f e1 (a2!:i) (a3!:i), i + 1) - -unzipP :: [:(a, b):] -> ([:a:], [:b:]) -unzipP a = (fst $ loop (mapEFL fst) noAL a, fst $ loop (mapEFL snd) noAL a) --- FIXME: these two functions should be optimised using a tupled custom loop -unzip3P :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) -unzip3P x = (fst $ loop (mapEFL fst3) noAL x, - fst $ loop (mapEFL snd3) noAL x, - fst $ loop (mapEFL trd3) noAL x) - where - fst3 (a, _, _) = a - snd3 (_, b, _) = b - trd3 (_, _, c) = c - --- instances --- - -instance Eq a => Eq [:a:] where - a1 == a2 | lengthP a1 == lengthP a2 = andP (zipWithP (==) a1 a2) - | otherwise = False - -instance Ord a => Ord [:a:] where - compare a1 a2 = case foldlP combineOrdering EQ (zipWithP compare a1 a2) of - EQ | lengthP a1 == lengthP a2 -> EQ - | lengthP a1 < lengthP a2 -> LT - | otherwise -> GT - where - combineOrdering EQ EQ = EQ - combineOrdering EQ other = other - combineOrdering other _ = other - -instance Functor [::] where - fmap = mapP - -instance Monad [::] where - m >>= k = foldrP ((+:+) . k ) [::] m - m >> k = foldrP ((+:+) . const k) [::] m - return x = [:x:] - fail _ = [::] - -instance Show a => Show [:a:] where - showsPrec _ = showPArr . fromP - where - showPArr [] s = "[::]" ++ s - showPArr (x:xs) s = "[:" ++ shows x (showPArr' xs s) - - showPArr' [] s = ":]" ++ s - showPArr' (y:ys) s = ',' : shows y (showPArr' ys s) - -instance Read a => Read [:a:] where - readsPrec _ a = [(toP v, rest) | (v, rest) <- readPArr a] - where - readPArr = readParen False (\r -> do - ("[:",s) <- lex r - readPArr1 s) - readPArr1 s = - (do { (":]", t) <- lex s; return ([], t) }) ++ - (do { (x, t) <- reads s; (xs, u) <- readPArr2 t; return (x:xs, u) }) - - readPArr2 s = - (do { (":]", t) <- lex s; return ([], t) }) ++ - (do { (",", t) <- lex s; (x, u) <- reads t; (xs, v) <- readPArr2 u; - return (x:xs, v) }) - --- overloaded functions --- - --- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of --- `Enum'. On the other hand, we really do not want to change `Enum'. Thus, --- for the moment, we hope that the compiler is sufficiently clever to --- properly fuse the following definitions. +singletonPArr :: a -> [:a:] +{-# NOINLINE singletonPArr #-} +singletonPArr e = replicatePArr 1 e -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 ) +indexPArr :: [:e:] -> Int -> e +{-# NOINLINE 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#) +lengthPArr :: [:a:] -> Int +{-# NOINLINE lengthPArr #-} +lengthPArr (PArr n# _) = I# n# -- auxiliary functions -- ------------------- @@ -600,133 +87,4 @@ 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#) - -#endif /* __HADDOCK__ */ - +#endif