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