Use explicit language extensions & remove extension fields from base.cabal
[packages/base.git] / GHC / PArr.hs
1 {-# LANGUAGE CPP, ParallelArrays, MagicHash, UnboxedTuples #-}
2 {-# OPTIONS_GHC -funbox-strict-fields #-}
3 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
4
5 -----------------------------------------------------------------------------
6 -- |
7 -- Module : GHC.PArr
8 -- Copyright : (c) 2001-2002 Manuel M T Chakravarty & Gabriele Keller
9 -- License : see libraries/base/LICENSE
10 --
11 -- Maintainer : Manuel M. T. Chakravarty <chak@cse.unsw.edu.au>
12 -- Stability : internal
13 -- Portability : non-portable (GHC Extensions)
14 --
15 -- Basic implementation of Parallel Arrays.
16 --
17 -- This module has two functions: (1) It defines the interface to the
18 -- parallel array extension of the Prelude and (2) it provides a vanilla
19 -- implementation of parallel arrays that does not require to flatten the
20 -- array code. The implementation is not very optimised.
21 --
22 --- DOCU ----------------------------------------------------------------------
23 --
24 -- Language: Haskell 98 plus unboxed values and parallel arrays
25 --
26 -- The semantic difference between standard Haskell arrays (aka "lazy
27 -- arrays") and parallel arrays (aka "strict arrays") is that the evaluation
28 -- of two different elements of a lazy array is independent, whereas in a
29 -- strict array either non or all elements are evaluated. In other words,
30 -- when a parallel array is evaluated to WHNF, all its elements will be
31 -- evaluated to WHNF. The name parallel array indicates that all array
32 -- elements may, in general, be evaluated to WHNF in parallel without any
33 -- need to resort to speculative evaluation. This parallel evaluation
34 -- semantics is also beneficial in the sequential case, as it facilitates
35 -- loop-based array processing as known from classic array-based languages,
36 -- such as Fortran.
37 --
38 -- The interface of this module is essentially a variant of the list
39 -- component of the Prelude, but also includes some functions (such as
40 -- permutations) that are not provided for lists. The following list
41 -- operations are not supported on parallel arrays, as they would require the
42 -- availability of infinite parallel arrays: `iterate', `repeat', and `cycle'.
43 --
44 -- The current implementation is quite simple and entirely based on boxed
45 -- arrays. One disadvantage of boxed arrays is that they require to
46 -- immediately initialise all newly allocated arrays with an error thunk to
47 -- keep the garbage collector happy, even if it is guaranteed that the array
48 -- is fully initialised with different values before passing over the
49 -- user-visible interface boundary. Currently, no effort is made to use
50 -- raw memory copy operations to speed things up.
51 --
52 --- TODO ----------------------------------------------------------------------
53 --
54 -- * We probably want a standard library `PArray' in addition to the prelude
55 -- extension in the same way as the standard library `List' complements the
56 -- list functions from the prelude.
57 --
58 -- * Currently, functions that emphasis the constructor-based definition of
59 -- lists (such as, head, last, tail, and init) are not supported.
60 --
61 -- Is it worthwhile to support the string processing functions lines,
62 -- words, unlines, and unwords? (Currently, they are not implemented.)
63 --
64 -- It can, however, be argued that it would be worthwhile to include them
65 -- for completeness' sake; maybe only in the standard library `PArray'.
66 --
67 -- * Prescans are often more useful for array programming than scans. Shall
68 -- we include them into the Prelude or the library?
69 --
70 -- * Due to the use of the iterator `loop', we could define some fusion rules
71 -- in this module.
72 --
73 -- * We might want to add bounds checks that can be deactivated.
74 --
75
76 module GHC.PArr (
77 -- [::], -- Built-in syntax
78
79 mapP, -- :: (a -> b) -> [:a:] -> [:b:]
80 (+:+), -- :: [:a:] -> [:a:] -> [:a:]
81 filterP, -- :: (a -> Bool) -> [:a:] -> [:a:]
82 concatP, -- :: [:[:a:]:] -> [:a:]
83 concatMapP, -- :: (a -> [:b:]) -> [:a:] -> [:b:]
84 -- head, last, tail, init, -- it's not wise to use them on arrays
85 nullP, -- :: [:a:] -> Bool
86 lengthP, -- :: [:a:] -> Int
87 (!:), -- :: [:a:] -> Int -> a
88 foldlP, -- :: (a -> b -> a) -> a -> [:b:] -> a
89 foldl1P, -- :: (a -> a -> a) -> [:a:] -> a
90 scanlP, -- :: (a -> b -> a) -> a -> [:b:] -> [:a:]
91 scanl1P, -- :: (a -> a -> a) -> [:a:] -> [:a:]
92 foldrP, -- :: (a -> b -> b) -> b -> [:a:] -> b
93 foldr1P, -- :: (a -> a -> a) -> [:a:] -> a
94 scanrP, -- :: (a -> b -> b) -> b -> [:a:] -> [:b:]
95 scanr1P, -- :: (a -> a -> a) -> [:a:] -> [:a:]
96 -- iterate, repeat, -- parallel arrays must be finite
97 singletonP, -- :: a -> [:a:]
98 emptyP, -- :: [:a:]
99 replicateP, -- :: Int -> a -> [:a:]
100 -- cycle, -- parallel arrays must be finite
101 takeP, -- :: Int -> [:a:] -> [:a:]
102 dropP, -- :: Int -> [:a:] -> [:a:]
103 splitAtP, -- :: Int -> [:a:] -> ([:a:],[:a:])
104 takeWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:]
105 dropWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:]
106 spanP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
107 breakP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
108 -- lines, words, unlines, unwords, -- is string processing really needed
109 reverseP, -- :: [:a:] -> [:a:]
110 andP, -- :: [:Bool:] -> Bool
111 orP, -- :: [:Bool:] -> Bool
112 anyP, -- :: (a -> Bool) -> [:a:] -> Bool
113 allP, -- :: (a -> Bool) -> [:a:] -> Bool
114 elemP, -- :: (Eq a) => a -> [:a:] -> Bool
115 notElemP, -- :: (Eq a) => a -> [:a:] -> Bool
116 lookupP, -- :: (Eq a) => a -> [:(a, b):] -> Maybe b
117 sumP, -- :: (Num a) => [:a:] -> a
118 productP, -- :: (Num a) => [:a:] -> a
119 maximumP, -- :: (Ord a) => [:a:] -> a
120 minimumP, -- :: (Ord a) => [:a:] -> a
121 zipP, -- :: [:a:] -> [:b:] -> [:(a, b) :]
122 zip3P, -- :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):]
123 zipWithP, -- :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:]
124 zipWith3P, -- :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:]
125 unzipP, -- :: [:(a, b) :] -> ([:a:], [:b:])
126 unzip3P, -- :: [:(a, b, c):] -> ([:a:], [:b:], [:c:])
127
128 -- overloaded functions
129 --
130 enumFromToP, -- :: Enum a => a -> a -> [:a:]
131 enumFromThenToP, -- :: Enum a => a -> a -> a -> [:a:]
132
133 -- the following functions are not available on lists
134 --
135 toP, -- :: [a] -> [:a:]
136 fromP, -- :: [:a:] -> [a]
137 sliceP, -- :: Int -> Int -> [:e:] -> [:e:]
138 foldP, -- :: (e -> e -> e) -> e -> [:e:] -> e
139 fold1P, -- :: (e -> e -> e) -> [:e:] -> e
140 permuteP, -- :: [:Int:] -> [:e:] -> [:e:]
141 bpermuteP, -- :: [:Int:] -> [:e:] -> [:e:]
142 dpermuteP, -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
143 crossP, -- :: [:a:] -> [:b:] -> [:(a, b):]
144 crossMapP, -- :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
145 indexOfP -- :: (a -> Bool) -> [:a:] -> [:Int:]
146 ) where
147
148 #ifndef __HADDOCK__
149
150 import Prelude
151
152 import GHC.ST ( ST(..), runST )
153 import GHC.Base ( Int#, Array#, Int(I#), MutableArray#, newArray#,
154 unsafeFreezeArray#, indexArray#, writeArray#, (<#), (>=#) )
155
156 infixl 9 !:
157 infixr 5 +:+
158 infix 4 `elemP`, `notElemP`
159
160
161 -- representation of parallel arrays
162 -- ---------------------------------
163
164 -- this rather straight forward implementation maps parallel arrays to the
165 -- internal representation used for standard Haskell arrays in GHC's Prelude
166 -- (EXPORTED ABSTRACTLY)
167 --
168 -- * This definition *must* be kept in sync with `TysWiredIn.parrTyCon'!
169 --
170 data [::] e = PArr Int# (Array# e)
171
172
173 -- exported operations on parallel arrays
174 -- --------------------------------------
175
176 -- operations corresponding to list operations
177 --
178
179 mapP :: (a -> b) -> [:a:] -> [:b:]
180 mapP f = fst . loop (mapEFL f) noAL
181
182 (+:+) :: [:a:] -> [:a:] -> [:a:]
183 a1 +:+ a2 = fst $ loop (mapEFL sel) noAL (enumFromToP 0 (len1 + len2 - 1))
184 -- we can't use the [:x..y:] form here for tedious
185 -- reasons to do with the typechecker and the fact that
186 -- `enumFromToP' is defined in the same module
187 where
188 len1 = lengthP a1
189 len2 = lengthP a2
190 --
191 sel i | i < len1 = a1!:i
192 | otherwise = a2!:(i - len1)
193
194 filterP :: (a -> Bool) -> [:a:] -> [:a:]
195 filterP p = fst . loop (filterEFL p) noAL
196
197 concatP :: [:[:a:]:] -> [:a:]
198 concatP xss = foldlP (+:+) [::] xss
199
200 concatMapP :: (a -> [:b:]) -> [:a:] -> [:b:]
201 concatMapP f = concatP . mapP f
202
203 -- head, last, tail, init, -- it's not wise to use them on arrays
204
205 nullP :: [:a:] -> Bool
206 nullP [::] = True
207 nullP _ = False
208
209 lengthP :: [:a:] -> Int
210 lengthP (PArr n# _) = I# n#
211
212 (!:) :: [:a:] -> Int -> a
213 (!:) = indexPArr
214
215 foldlP :: (a -> b -> a) -> a -> [:b:] -> a
216 foldlP f z = snd . loop (foldEFL (flip f)) z
217
218 foldl1P :: (a -> a -> a) -> [:a:] -> a
219 foldl1P _ [::] = error "Prelude.foldl1P: empty array"
220 foldl1P f a = snd $ loopFromTo 1 (lengthP a - 1) (foldEFL f) (a!:0) a
221
222 scanlP :: (a -> b -> a) -> a -> [:b:] -> [:a:]
223 scanlP f z = fst . loop (scanEFL (flip f)) z
224
225 scanl1P :: (a -> a -> a) -> [:a:] -> [:a:]
226 scanl1P _ [::] = error "Prelude.scanl1P: empty array"
227 scanl1P f a = fst $ loopFromTo 1 (lengthP a - 1) (scanEFL f) (a!:0) a
228
229 foldrP :: (a -> b -> b) -> b -> [:a:] -> b
230 foldrP = error "Prelude.foldrP: not implemented yet" -- FIXME
231
232 foldr1P :: (a -> a -> a) -> [:a:] -> a
233 foldr1P = error "Prelude.foldr1P: not implemented yet" -- FIXME
234
235 scanrP :: (a -> b -> b) -> b -> [:a:] -> [:b:]
236 scanrP = error "Prelude.scanrP: not implemented yet" -- FIXME
237
238 scanr1P :: (a -> a -> a) -> [:a:] -> [:a:]
239 scanr1P = error "Prelude.scanr1P: not implemented yet" -- FIXME
240
241 -- iterate, repeat -- parallel arrays must be finite
242
243 singletonP :: a -> [:a:]
244 {-# INLINE singletonP #-}
245 singletonP e = replicateP 1 e
246
247 emptyP:: [:a:]
248 {- NOINLINE emptyP #-}
249 emptyP = replicateP 0 undefined
250
251
252 replicateP :: Int -> a -> [:a:]
253 {-# INLINE replicateP #-}
254 replicateP n e = runST (do
255 marr# <- newArray n e
256 mkPArr n marr#)
257
258 -- cycle -- parallel arrays must be finite
259
260 takeP :: Int -> [:a:] -> [:a:]
261 takeP n = sliceP 0 (n - 1)
262
263 dropP :: Int -> [:a:] -> [:a:]
264 dropP n a = sliceP n (lengthP a - 1) a
265
266 splitAtP :: Int -> [:a:] -> ([:a:],[:a:])
267 splitAtP n xs = (takeP n xs, dropP n xs)
268
269 takeWhileP :: (a -> Bool) -> [:a:] -> [:a:]
270 takeWhileP = error "Prelude.takeWhileP: not implemented yet" -- FIXME
271
272 dropWhileP :: (a -> Bool) -> [:a:] -> [:a:]
273 dropWhileP = error "Prelude.dropWhileP: not implemented yet" -- FIXME
274
275 spanP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
276 spanP = error "Prelude.spanP: not implemented yet" -- FIXME
277
278 breakP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:])
279 breakP p = spanP (not . p)
280
281 -- lines, words, unlines, unwords, -- is string processing really needed
282
283 reverseP :: [:a:] -> [:a:]
284 reverseP a = permuteP (enumFromThenToP (len - 1) (len - 2) 0) a
285 -- we can't use the [:x, y..z:] form here for tedious
286 -- reasons to do with the typechecker and the fact that
287 -- `enumFromThenToP' is defined in the same module
288 where
289 len = lengthP a
290
291 andP :: [:Bool:] -> Bool
292 andP = foldP (&&) True
293
294 orP :: [:Bool:] -> Bool
295 orP = foldP (||) True
296
297 anyP :: (a -> Bool) -> [:a:] -> Bool
298 anyP p = orP . mapP p
299
300 allP :: (a -> Bool) -> [:a:] -> Bool
301 allP p = andP . mapP p
302
303 elemP :: (Eq a) => a -> [:a:] -> Bool
304 elemP x = anyP (== x)
305
306 notElemP :: (Eq a) => a -> [:a:] -> Bool
307 notElemP x = allP (/= x)
308
309 lookupP :: (Eq a) => a -> [:(a, b):] -> Maybe b
310 lookupP = error "Prelude.lookupP: not implemented yet" -- FIXME
311
312 sumP :: (Num a) => [:a:] -> a
313 sumP = foldP (+) 0
314
315 productP :: (Num a) => [:a:] -> a
316 productP = foldP (*) 1
317
318 maximumP :: (Ord a) => [:a:] -> a
319 maximumP [::] = error "Prelude.maximumP: empty parallel array"
320 maximumP xs = fold1P max xs
321
322 minimumP :: (Ord a) => [:a:] -> a
323 minimumP [::] = error "Prelude.minimumP: empty parallel array"
324 minimumP xs = fold1P min xs
325
326 zipP :: [:a:] -> [:b:] -> [:(a, b):]
327 zipP = zipWithP (,)
328
329 zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):]
330 zip3P = zipWith3P (,,)
331
332 zipWithP :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:]
333 zipWithP f a1 a2 = let
334 len1 = lengthP a1
335 len2 = lengthP a2
336 len = len1 `min` len2
337 in
338 fst $ loopFromTo 0 (len - 1) combine 0 a1
339 where
340 combine e1 i = (Just $ f e1 (a2!:i), i + 1)
341
342 zipWith3P :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:]
343 zipWith3P f a1 a2 a3 = let
344 len1 = lengthP a1
345 len2 = lengthP a2
346 len3 = lengthP a3
347 len = len1 `min` len2 `min` len3
348 in
349 fst $ loopFromTo 0 (len - 1) combine 0 a1
350 where
351 combine e1 i = (Just $ f e1 (a2!:i) (a3!:i), i + 1)
352
353 unzipP :: [:(a, b):] -> ([:a:], [:b:])
354 unzipP a = (fst $ loop (mapEFL fst) noAL a, fst $ loop (mapEFL snd) noAL a)
355 -- FIXME: these two functions should be optimised using a tupled custom loop
356 unzip3P :: [:(a, b, c):] -> ([:a:], [:b:], [:c:])
357 unzip3P x = (fst $ loop (mapEFL fst3) noAL x,
358 fst $ loop (mapEFL snd3) noAL x,
359 fst $ loop (mapEFL trd3) noAL x)
360 where
361 fst3 (a, _, _) = a
362 snd3 (_, b, _) = b
363 trd3 (_, _, c) = c
364
365 -- instances
366 --
367
368 instance Eq a => Eq [:a:] where
369 a1 == a2 | lengthP a1 == lengthP a2 = andP (zipWithP (==) a1 a2)
370 | otherwise = False
371
372 instance Ord a => Ord [:a:] where
373 compare a1 a2 = case foldlP combineOrdering EQ (zipWithP compare a1 a2) of
374 EQ | lengthP a1 == lengthP a2 -> EQ
375 | lengthP a1 < lengthP a2 -> LT
376 | otherwise -> GT
377 where
378 combineOrdering EQ EQ = EQ
379 combineOrdering EQ other = other
380 combineOrdering other _ = other
381
382 instance Functor [::] where
383 fmap = mapP
384
385 instance Monad [::] where
386 m >>= k = foldrP ((+:+) . k ) [::] m
387 m >> k = foldrP ((+:+) . const k) [::] m
388 return x = [:x:]
389 fail _ = [::]
390
391 instance Show a => Show [:a:] where
392 showsPrec _ = showPArr . fromP
393 where
394 showPArr [] s = "[::]" ++ s
395 showPArr (x:xs) s = "[:" ++ shows x (showPArr' xs s)
396
397 showPArr' [] s = ":]" ++ s
398 showPArr' (y:ys) s = ',' : shows y (showPArr' ys s)
399
400 instance Read a => Read [:a:] where
401 readsPrec _ a = [(toP v, rest) | (v, rest) <- readPArr a]
402 where
403 readPArr = readParen False (\r -> do
404 ("[:",s) <- lex r
405 readPArr1 s)
406 readPArr1 s =
407 (do { (":]", t) <- lex s; return ([], t) }) ++
408 (do { (x, t) <- reads s; (xs, u) <- readPArr2 t; return (x:xs, u) })
409
410 readPArr2 s =
411 (do { (":]", t) <- lex s; return ([], t) }) ++
412 (do { (",", t) <- lex s; (x, u) <- reads t; (xs, v) <- readPArr2 u;
413 return (x:xs, v) })
414
415 -- overloaded functions
416 --
417
418 -- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of
419 -- `Enum'. On the other hand, we really do not want to change `Enum'. Thus,
420 -- for the moment, we hope that the compiler is sufficiently clever to
421 -- properly fuse the following definitions.
422
423 enumFromToP :: Enum a => a -> a -> [:a:]
424 enumFromToP x0 y0 = mapP toEnum (eftInt (fromEnum x0) (fromEnum y0))
425 where
426 eftInt x y = scanlP (+) x $ replicateP (y - x + 1) 1
427
428 enumFromThenToP :: Enum a => a -> a -> a -> [:a:]
429 enumFromThenToP x0 y0 z0 =
430 mapP toEnum (efttInt (fromEnum x0) (fromEnum y0) (fromEnum z0))
431 where
432 efttInt x y z = scanlP (+) x $
433 replicateP (abs (z - x) `div` abs delta + 1) delta
434 where
435 delta = y - x
436
437 -- the following functions are not available on lists
438 --
439
440 -- create an array from a list (EXPORTED)
441 --
442 toP :: [a] -> [:a:]
443 toP l = fst $ loop store l (replicateP (length l) ())
444 where
445 store _ (x:xs) = (Just x, xs)
446
447 -- convert an array to a list (EXPORTED)
448 --
449 fromP :: [:a:] -> [a]
450 fromP a = [a!:i | i <- [0..lengthP a - 1]]
451
452 -- cut a subarray out of an array (EXPORTED)
453 --
454 sliceP :: Int -> Int -> [:e:] -> [:e:]
455 sliceP from to a =
456 fst $ loopFromTo (0 `max` from) (to `min` (lengthP a - 1)) (mapEFL id) noAL a
457
458 -- parallel folding (EXPORTED)
459 --
460 -- * the first argument must be associative; otherwise, the result is undefined
461 --
462 foldP :: (e -> e -> e) -> e -> [:e:] -> e
463 foldP = foldlP
464
465 -- parallel folding without explicit neutral (EXPORTED)
466 --
467 -- * the first argument must be associative; otherwise, the result is undefined
468 --
469 fold1P :: (e -> e -> e) -> [:e:] -> e
470 fold1P = foldl1P
471
472 -- permute an array according to the permutation vector in the first argument
473 -- (EXPORTED)
474 --
475 permuteP :: [:Int:] -> [:e:] -> [:e:]
476 permuteP is es
477 | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"
478 | otherwise = runST (do
479 marr <- newArray isLen noElem
480 permute marr is es
481 mkPArr isLen marr)
482 where
483 noElem = error "GHC.PArr.permuteP: I do not exist!"
484 -- unlike standard Haskell arrays, this value represents an
485 -- internal error
486 isLen = lengthP is
487 esLen = lengthP es
488
489 -- permute an array according to the back-permutation vector in the first
490 -- argument (EXPORTED)
491 --
492 -- * the permutation vector must represent a surjective function; otherwise,
493 -- the result is undefined
494 --
495 bpermuteP :: [:Int:] -> [:e:] -> [:e:]
496 bpermuteP is es = fst $ loop (mapEFL (es!:)) noAL is
497
498 -- permute an array according to the permutation vector in the first
499 -- argument, which need not be surjective (EXPORTED)
500 --
501 -- * any elements in the result that are not covered by the permutation
502 -- vector assume the value of the corresponding position of the third
503 -- argument
504 --
505 dpermuteP :: [:Int:] -> [:e:] -> [:e:] -> [:e:]
506 dpermuteP is es dft
507 | isLen /= esLen = error "GHC.PArr: arguments must be of the same length"
508 | otherwise = runST (do
509 marr <- newArray dftLen noElem
510 _ <- trans 0 (isLen - 1) marr dft copyOne noAL
511 permute marr is es
512 mkPArr dftLen marr)
513 where
514 noElem = error "GHC.PArr.permuteP: I do not exist!"
515 -- unlike standard Haskell arrays, this value represents an
516 -- internal error
517 isLen = lengthP is
518 esLen = lengthP es
519 dftLen = lengthP dft
520
521 copyOne e _ = (Just e, noAL)
522
523 -- computes the cross combination of two arrays (EXPORTED)
524 --
525 crossP :: [:a:] -> [:b:] -> [:(a, b):]
526 crossP a1 a2 = fst $ loop combine (0, 0) $ replicateP len ()
527 where
528 len1 = lengthP a1
529 len2 = lengthP a2
530 len = len1 * len2
531 --
532 combine _ (i, j) = (Just $ (a1!:i, a2!:j), next)
533 where
534 next | (i + 1) == len1 = (0 , j + 1)
535 | otherwise = (i + 1, j)
536
537 {- An alternative implementation
538 * The one above is certainly better for flattened code, but here where we
539 are handling boxed arrays, the trade off is less clear. However, I
540 think, the above one is still better.
541
542 crossP a1 a2 = let
543 len1 = lengthP a1
544 len2 = lengthP a2
545 x1 = concatP $ mapP (replicateP len2) a1
546 x2 = concatP $ replicateP len1 a2
547 in
548 zipP x1 x2
549 -}
550
551 -- |Compute a cross of an array and the arrays produced by the given function
552 -- for the elements of the first array.
553 --
554 crossMapP :: [:a:] -> (a -> [:b:]) -> [:(a, b):]
555 crossMapP a f = let
556 bs = mapP f a
557 segd = mapP lengthP bs
558 as = zipWithP replicateP segd a
559 in
560 zipP (concatP as) (concatP bs)
561
562 {- The following may seem more straight forward, but the above is very cheap
563 with segmented arrays, as `mapP lengthP', `zipP', and `concatP' are
564 constant time, and `map f' uses the lifted version of `f'.
565
566 crossMapP a f = concatP $ mapP (\x -> mapP ((,) x) (f x)) a
567
568 -}
569
570 -- computes an index array for all elements of the second argument for which
571 -- the predicate yields `True' (EXPORTED)
572 --
573 indexOfP :: (a -> Bool) -> [:a:] -> [:Int:]
574 indexOfP p a = fst $ loop calcIdx 0 a
575 where
576 calcIdx e idx | p e = (Just idx, idx + 1)
577 | otherwise = (Nothing , idx )
578
579
580 -- auxiliary functions
581 -- -------------------
582
583 -- internally used mutable boxed arrays
584 --
585 data MPArr s e = MPArr Int# (MutableArray# s e)
586
587 -- allocate a new mutable array that is pre-initialised with a given value
588 --
589 newArray :: Int -> e -> ST s (MPArr s e)
590 {-# INLINE newArray #-}
591 newArray (I# n#) e = ST $ \s1# ->
592 case newArray# n# e s1# of { (# s2#, marr# #) ->
593 (# s2#, MPArr n# marr# #)}
594
595 -- convert a mutable array into the external parallel array representation
596 --
597 mkPArr :: Int -> MPArr s e -> ST s [:e:]
598 {-# INLINE mkPArr #-}
599 mkPArr (I# n#) (MPArr _ marr#) = ST $ \s1# ->
600 case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) ->
601 (# s2#, PArr n# arr# #) }
602
603 -- general array iterator
604 --
605 -- * corresponds to `loopA' from ``Functional Array Fusion'', Chakravarty &
606 -- Keller, ICFP 2001
607 --
608 loop :: (e -> acc -> (Maybe e', acc)) -- mapping & folding, once per element
609 -> acc -- initial acc value
610 -> [:e:] -- input array
611 -> ([:e':], acc)
612 {-# INLINE loop #-}
613 loop mf acc arr = loopFromTo 0 (lengthP arr - 1) mf acc arr
614
615 -- general array iterator with bounds
616 --
617 loopFromTo :: Int -- from index
618 -> Int -- to index
619 -> (e -> acc -> (Maybe e', acc))
620 -> acc
621 -> [:e:]
622 -> ([:e':], acc)
623 {-# INLINE loopFromTo #-}
624 loopFromTo from to mf start arr = runST (do
625 marr <- newArray (to - from + 1) noElem
626 (n', acc) <- trans from to marr arr mf start
627 arr' <- mkPArr n' marr
628 return (arr', acc))
629 where
630 noElem = error "GHC.PArr.loopFromTo: I do not exist!"
631 -- unlike standard Haskell arrays, this value represents an
632 -- internal error
633
634 -- actual loop body of `loop'
635 --
636 -- * for this to be really efficient, it has to be translated with the
637 -- constructor specialisation phase "SpecConstr" switched on; as of GHC 5.03
638 -- this requires an optimisation level of at least -O2
639 --
640 trans :: Int -- index of first elem to process
641 -> Int -- index of last elem to process
642 -> MPArr s e' -- destination array
643 -> [:e:] -- source array
644 -> (e -> acc -> (Maybe e', acc)) -- mutator
645 -> acc -- initial accumulator
646 -> ST s (Int, acc) -- final destination length/final acc
647 {-# INLINE trans #-}
648 trans from to marr arr mf start = trans' from 0 start
649 where
650 trans' arrOff marrOff acc
651 | arrOff > to = return (marrOff, acc)
652 | otherwise = do
653 let (oe', acc') = mf (arr `indexPArr` arrOff) acc
654 marrOff' <- case oe' of
655 Nothing -> return marrOff
656 Just e' -> do
657 writeMPArr marr marrOff e'
658 return $ marrOff + 1
659 trans' (arrOff + 1) marrOff' acc'
660
661 -- Permute the given elements into the mutable array.
662 --
663 permute :: MPArr s e -> [:Int:] -> [:e:] -> ST s ()
664 permute marr is es = perm 0
665 where
666 perm i
667 | i == n = return ()
668 | otherwise = writeMPArr marr (is!:i) (es!:i) >> perm (i + 1)
669 where
670 n = lengthP is
671
672
673 -- common patterns for using `loop'
674 --
675
676 -- initial value for the accumulator when the accumulator is not needed
677 --
678 noAL :: ()
679 noAL = ()
680
681 -- `loop' mutator maps a function over array elements
682 --
683 mapEFL :: (e -> e') -> (e -> () -> (Maybe e', ()))
684 {-# INLINE mapEFL #-}
685 mapEFL f = \e _ -> (Just $ f e, ())
686
687 -- `loop' mutator that filter elements according to a predicate
688 --
689 filterEFL :: (e -> Bool) -> (e -> () -> (Maybe e, ()))
690 {-# INLINE filterEFL #-}
691 filterEFL p = \e _ -> if p e then (Just e, ()) else (Nothing, ())
692
693 -- `loop' mutator for array folding
694 --
695 foldEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe (), acc))
696 {-# INLINE foldEFL #-}
697 foldEFL f = \e a -> (Nothing, f e a)
698
699 -- `loop' mutator for array scanning
700 --
701 scanEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe acc, acc))
702 {-# INLINE scanEFL #-}
703 scanEFL f = \e a -> (Just a, f e a)
704
705 -- elementary array operations
706 --
707
708 -- unlifted array indexing
709 --
710 indexPArr :: [:e:] -> Int -> e
711 {-# INLINE indexPArr #-}
712 indexPArr (PArr n# arr#) (I# i#)
713 | i# >=# 0# && i# <# n# =
714 case indexArray# arr# i# of (# e #) -> e
715 | otherwise = error $ "indexPArr: out of bounds parallel array index; " ++
716 "idx = " ++ show (I# i#) ++ ", arr len = "
717 ++ show (I# n#)
718
719 -- encapsulate writing into a mutable array into the `ST' monad
720 --
721 writeMPArr :: MPArr s e -> Int -> e -> ST s ()
722 {-# INLINE writeMPArr #-}
723 writeMPArr (MPArr n# marr#) (I# i#) e
724 | i# >=# 0# && i# <# n# =
725 ST $ \s# ->
726 case writeArray# marr# i# e s# of s'# -> (# s'#, () #)
727 | otherwise = error $ "writeMPArr: out of bounds parallel array index; " ++
728 "idx = " ++ show (I# i#) ++ ", arr len = "
729 ++ show (I# n#)
730
731 #endif /* __HADDOCK__ */
732