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