Import Data.ByteString.Lazy, improve ByteString Fusion, and resync with FPS head
[packages/random.git] / Data / ByteString / Fusion.hs
1 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}
2 --
3 -- Module : Data.ByteString.Fusion
4 -- License : BSD-style
5 -- Maintainer : dons@cse.unsw.edu.au
6 -- Stability : experimental
7 -- Portability : portable, requires ffi and cpp
8 -- Tested with : GHC 6.4.1 and Hugs March 2005
9 --
10
11 --
12 -- | Functional array fusion for ByteStrings.
13 --
14 -- Originally based on code from the Data Parallel Haskell project,
15 -- <http://www.cse.unsw.edu.au/~chak/project/dph>
16 --
17 module Data.ByteString.Fusion (
18
19 -- * Fusion utilities
20 loopU, loopL, fuseEFL,
21 NoAcc(NoAcc), loopArr, loopAcc, loopSndAcc, unSP,
22 mapEFL, filterEFL, foldEFL, foldEFL', scanEFL, mapAccumEFL, mapIndexEFL,
23
24 -- ** Alternative Fusion stuff
25 -- | This replaces 'loopU' with 'loopUp'
26 -- and adds several further special cases of loops.
27 loopUp, loopDown, loopNoAcc, loopMap, loopFilter,
28 loopWrapper, sequenceLoops,
29 doUpLoop, doDownLoop, doNoAccLoop, doMapLoop, doFilterLoop,
30
31 -- | These are the special fusion cases for combining each loop form perfectly.
32 fuseAccAccEFL, fuseAccNoAccEFL, fuseNoAccAccEFL, fuseNoAccNoAccEFL,
33 fuseMapAccEFL, fuseAccMapEFL, fuseMapNoAccEFL, fuseNoAccMapEFL,
34 fuseMapMapEFL, fuseAccFilterEFL, fuseFilterAccEFL, fuseNoAccFilterEFL,
35 fuseFilterNoAccEFL, fuseFilterFilterEFL, fuseMapFilterEFL, fuseFilterMapEFL,
36
37 -- * Strict pairs and sums
38 PairS(..), MaybeS(..)
39
40 ) where
41
42 import Data.ByteString.Base
43
44 import Foreign.ForeignPtr
45 import Foreign.Ptr
46 import Foreign.Storable (Storable(..))
47
48 import Data.Word (Word8)
49 import System.IO.Unsafe (unsafePerformIO)
50
51 -- -----------------------------------------------------------------------------
52 --
53 -- Useful macros, until we have bang patterns
54 --
55
56 #define STRICT1(f) f a | a `seq` False = undefined
57 #define STRICT2(f) f a b | a `seq` b `seq` False = undefined
58 #define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
59 #define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined
60 #define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined
61
62 infixl 2 :*:
63
64 -- |Strict pair
65 data PairS a b = !a :*: !b deriving (Eq,Ord,Show)
66
67 -- |Strict Maybe
68 data MaybeS a = NothingS | JustS !a deriving (Eq,Ord,Show)
69
70 -- |Data type for accumulators which can be ignored. The rewrite rules rely on
71 -- the fact that no bottoms of this type are ever constructed; hence, we can
72 -- assume @(_ :: NoAcc) `seq` x = x@.
73 --
74 data NoAcc = NoAcc
75
76 -- |Type of loop functions
77 type AccEFL acc = acc -> Word8 -> (PairS acc (MaybeS Word8))
78 type NoAccEFL = Word8 -> MaybeS Word8
79 type MapEFL = Word8 -> Word8
80 type FilterEFL = Word8 -> Bool
81
82 infixr 9 `fuseEFL`
83
84 -- |Fuse to flat loop functions
85 fuseEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
86 fuseEFL f g (acc1 :*: acc2) e1 =
87 case f acc1 e1 of
88 acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
89 acc1' :*: JustS e2 ->
90 case g acc2 e2 of
91 acc2' :*: res -> (acc1' :*: acc2') :*: res
92 #if defined(__GLASGOW_HASKELL__)
93 {-# INLINE [1] fuseEFL #-}
94 #endif
95
96 -- | Special forms of loop arguments
97 --
98 -- * These are common special cases for the three function arguments of gen
99 -- and loop; we give them special names to make it easier to trigger RULES
100 -- applying in the special cases represented by these arguments. The
101 -- "INLINE [1]" makes sure that these functions are only inlined in the last
102 -- two simplifier phases.
103 --
104 -- * In the case where the accumulator is not needed, it is better to always
105 -- explicitly return a value `()', rather than just copy the input to the
106 -- output, as the former gives GHC better local information.
107 --
108
109 -- | Element function expressing a mapping only
110 #if !defined(LOOPNOACC_FUSION)
111 mapEFL :: (Word8 -> Word8) -> AccEFL NoAcc
112 mapEFL f = \_ e -> (NoAcc :*: (JustS $ f e))
113 #else
114 mapEFL :: (Word8 -> Word8) -> NoAccEFL
115 mapEFL f = \e -> JustS (f e)
116 #endif
117 #if defined(__GLASGOW_HASKELL__)
118 {-# INLINE [1] mapEFL #-}
119 #endif
120
121 -- | Element function implementing a filter function only
122 #if !defined(LOOPNOACC_FUSION)
123 filterEFL :: (Word8 -> Bool) -> AccEFL NoAcc
124 filterEFL p = \_ e -> if p e then (NoAcc :*: JustS e) else (NoAcc :*: NothingS)
125 #else
126 filterEFL :: (Word8 -> Bool) -> NoAccEFL
127 filterEFL p = \e -> if p e then JustS e else NothingS
128 #endif
129
130 #if defined(__GLASGOW_HASKELL__)
131 {-# INLINE [1] filterEFL #-}
132 #endif
133
134 -- |Element function expressing a reduction only
135 foldEFL :: (acc -> Word8 -> acc) -> AccEFL acc
136 foldEFL f = \a e -> (f a e :*: NothingS)
137 #if defined(__GLASGOW_HASKELL__)
138 {-# INLINE [1] foldEFL #-}
139 #endif
140
141 -- | A strict foldEFL.
142 foldEFL' :: (acc -> Word8 -> acc) -> AccEFL acc
143 foldEFL' f = \a e -> let a' = f a e in a' `seq` (a' :*: NothingS)
144 #if defined(__GLASGOW_HASKELL__)
145 {-# INLINE [1] foldEFL' #-}
146 #endif
147
148 -- | Element function expressing a prefix reduction only
149 --
150 scanEFL :: (Word8 -> Word8 -> Word8) -> AccEFL Word8
151 scanEFL f = \a e -> (f a e :*: JustS a)
152 #if defined(__GLASGOW_HASKELL__)
153 {-# INLINE [1] scanEFL #-}
154 #endif
155
156 -- | Element function implementing a map and fold
157 --
158 mapAccumEFL :: (acc -> Word8 -> (acc, Word8)) -> AccEFL acc
159 mapAccumEFL f = \a e -> case f a e of (a', e') -> (a' :*: JustS e')
160 #if defined(__GLASGOW_HASKELL__)
161 {-# INLINE [1] mapAccumEFL #-}
162 #endif
163
164 -- | Element function implementing a map with index
165 --
166 mapIndexEFL :: (Int -> Word8 -> Word8) -> AccEFL Int
167 mapIndexEFL f = \i e -> let i' = i+1 in i' `seq` (i' :*: JustS (f i e))
168 #if defined(__GLASGOW_HASKELL__)
169 {-# INLINE [1] mapIndexEFL #-}
170 #endif
171
172 -- | Projection functions that are fusion friendly (as in, we determine when
173 -- they are inlined)
174 loopArr :: (PairS acc arr) -> arr
175 loopArr (_ :*: arr) = arr
176 #if defined(__GLASGOW_HASKELL__)
177 {-# INLINE [1] loopArr #-}
178 #endif
179
180 loopAcc :: (PairS acc arr) -> acc
181 loopAcc (acc :*: _) = acc
182 #if defined(__GLASGOW_HASKELL__)
183 {-# INLINE [1] loopAcc #-}
184 #endif
185
186 loopSndAcc :: (PairS (PairS acc1 acc2) arr) -> (PairS acc2 arr)
187 loopSndAcc ((_ :*: acc) :*: arr) = (acc :*: arr)
188 #if defined(__GLASGOW_HASKELL__)
189 {-# INLINE [1] loopSndAcc #-}
190 #endif
191
192 unSP :: (PairS acc arr) -> (acc, arr)
193 unSP (acc :*: arr) = (acc, arr)
194 #if defined(__GLASGOW_HASKELL__)
195 {-# INLINE [1] unSP #-}
196 #endif
197
198 ------------------------------------------------------------------------
199 --
200 -- Loop combinator and fusion rules for flat arrays
201 -- |Iteration over over ByteStrings
202
203 -- | Iteration over over ByteStrings
204 loopU :: AccEFL acc -- ^ mapping & folding, once per elem
205 -> acc -- ^ initial acc value
206 -> ByteString -- ^ input ByteString
207 -> (PairS acc ByteString)
208
209 loopU f start (PS z s i) = unsafePerformIO $ withForeignPtr z $ \a -> do
210 (ps, acc) <- createAndTrim' i $ \p -> do
211 (acc' :*: i') <- go (a `plusPtr` s) p start
212 return (0, i', acc')
213 return (acc :*: ps)
214
215 where
216 go p ma = trans 0 0
217 where
218 STRICT3(trans)
219 trans a_off ma_off acc
220 | a_off >= i = return (acc :*: ma_off)
221 | otherwise = do
222 x <- peekByteOff p a_off
223 let (acc' :*: oe) = f acc x
224 ma_off' <- case oe of
225 NothingS -> return ma_off
226 JustS e -> do pokeByteOff ma ma_off e
227 return $ ma_off + 1
228 trans (a_off+1) ma_off' acc'
229
230 #if defined(__GLASGOW_HASKELL__)
231 {-# INLINE [1] loopU #-}
232 #endif
233
234 {-# RULES
235
236 "loop/loop fusion!" forall em1 em2 start1 start2 arr.
237 loopU em2 start2 (loopArr (loopU em1 start1 arr)) =
238 loopSndAcc (loopU (em1 `fuseEFL` em2) (start1 :*: start2) arr)
239
240 #-}
241
242 --
243 -- Functional list/array fusion for lazy ByteStrings.
244 --
245 loopL :: AccEFL acc -- ^ mapping & folding, once per elem
246 -> acc -- ^ initial acc value
247 -> [ByteString] -- ^ input ByteString
248 -> PairS acc [ByteString]
249 loopL f = loop
250 where loop s [] = (s :*: [])
251 loop s (x:xs)
252 | l == 0 = (s'' :*: ys)
253 | otherwise = (s'' :*: y:ys)
254 where (s' :*: y@(PS _ _ l)) = loopU f s x -- avoid circular dep on P.null
255 (s'' :*: ys) = loop s' xs
256
257 #if defined(__GLASGOW_HASKELL__)
258 {-# INLINE [1] loopL #-}
259 #endif
260
261 {-# RULES
262
263 "lazy loop/loop fusion!" forall em1 em2 start1 start2 arr.
264 loopL em2 start2 (loopArr (loopL em1 start1 arr)) =
265 loopSndAcc (loopL (em1 `fuseEFL` em2) (start1 :*: start2) arr)
266
267 #-}
268
269
270 {-
271
272 Alternate experimental formulation of loopU which partitions it into
273 an allocating wrapper and an imperitive array-mutating loop.
274
275 The point in doing this split is that we might be able to fuse multiple
276 loops into a single wrapper. This would save reallocating another buffer.
277 It should also give better cache locality by reusing the buffer.
278
279 Note that this stuff needs ghc-6.5 from May 26 or later for the RULES to
280 really work reliably.
281
282 -}
283
284 loopUp :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
285 loopUp f a arr = loopWrapper (doUpLoop f a) arr
286 {-# INLINE loopUp #-}
287
288 loopDown :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
289 loopDown f a arr = loopWrapper (doDownLoop f a) arr
290 {-# INLINE loopDown #-}
291
292 loopNoAcc :: NoAccEFL -> ByteString -> PairS NoAcc ByteString
293 loopNoAcc f arr = loopWrapper (doNoAccLoop f NoAcc) arr
294 {-# INLINE loopNoAcc #-}
295
296 loopMap :: MapEFL -> ByteString -> PairS NoAcc ByteString
297 loopMap f arr = loopWrapper (doMapLoop f NoAcc) arr
298 {-# INLINE loopMap #-}
299
300 loopFilter :: FilterEFL -> ByteString -> PairS NoAcc ByteString
301 loopFilter f arr = loopWrapper (doFilterLoop f NoAcc) arr
302 {-# INLINE loopFilter #-}
303
304 -- The type of imperitive loops that fill in a destination array by
305 -- reading a source array. They may not fill in the whole of the dest
306 -- array if the loop is behaving as a filter, this is why we return
307 -- the length that was filled in. The loop may also accumulate some
308 -- value as it loops over the source array.
309 --
310 type ImperativeLoop acc =
311 Ptr Word8 -- pointer to the start of the source byte array
312 -> Ptr Word8 -- pointer to ther start of the destination byte array
313 -> Int -- length of the source byte array
314 -> IO (PairS (PairS acc Int) Int) -- result and offset, length of dest that was filled
315
316 loopWrapper :: ImperativeLoop acc -> ByteString -> PairS acc ByteString
317 loopWrapper body (PS srcFPtr srcOffset srcLen) = unsafePerformIO $
318 withForeignPtr srcFPtr $ \srcPtr -> do
319 (ps, acc) <- createAndTrim' srcLen $ \destPtr -> do
320 (acc :*: destOffset :*: destLen) <-
321 body (srcPtr `plusPtr` srcOffset) destPtr srcLen
322 return (destOffset, destLen, acc)
323 return (acc :*: ps)
324
325 doUpLoop :: AccEFL acc -> acc -> ImperativeLoop acc
326 doUpLoop f acc0 src dest len = loop 0 0 acc0
327 where STRICT3(loop)
328 loop src_off dest_off acc
329 | src_off >= len = return (acc :*: 0 :*: dest_off)
330 | otherwise = do
331 x <- peekByteOff src src_off
332 case f acc x of
333 (acc' :*: NothingS) -> loop (src_off+1) dest_off acc'
334 (acc' :*: JustS x') -> pokeByteOff dest dest_off x'
335 >> loop (src_off+1) (dest_off+1) acc'
336
337 doDownLoop :: AccEFL acc -> acc -> ImperativeLoop acc
338 doDownLoop f acc0 src dest len = loop (len-1) (len-1) acc0
339 where STRICT3(loop)
340 loop src_off dest_off acc
341 | src_off < 0 = return (acc :*: dest_off + 1 :*: len - (dest_off + 1))
342 | otherwise = do
343 x <- peekByteOff src src_off
344 case f acc x of
345 (acc' :*: NothingS) -> loop (src_off-1) dest_off acc'
346 (acc' :*: JustS x') -> pokeByteOff dest dest_off x'
347 >> loop (src_off-1) (dest_off-1) acc'
348
349 doNoAccLoop :: NoAccEFL -> noAcc -> ImperativeLoop noAcc
350 doNoAccLoop f noAcc src dest len = loop 0 0
351 where STRICT2(loop)
352 loop src_off dest_off
353 | src_off >= len = return (noAcc :*: 0 :*: dest_off)
354 | otherwise = do
355 x <- peekByteOff src src_off
356 case f x of
357 NothingS -> loop (src_off+1) dest_off
358 JustS x' -> pokeByteOff dest dest_off x'
359 >> loop (src_off+1) (dest_off+1)
360
361 doMapLoop :: MapEFL -> noAcc -> ImperativeLoop noAcc
362 doMapLoop f noAcc src dest len = loop 0
363 where STRICT1(loop)
364 loop n
365 | n >= len = return (noAcc :*: 0 :*: len)
366 | otherwise = do
367 x <- peekByteOff src n
368 pokeByteOff dest n (f x)
369 loop (n+1) -- offset always the same, only pass 1 arg
370
371 doFilterLoop :: FilterEFL -> noAcc -> ImperativeLoop noAcc
372 doFilterLoop f noAcc src dest len = loop 0 0
373 where STRICT2(loop)
374 loop src_off dest_off
375 | src_off >= len = return (noAcc :*: 0 :*: dest_off)
376 | otherwise = do
377 x <- peekByteOff src src_off
378 if f x
379 then pokeByteOff dest dest_off x
380 >> loop (src_off+1) (dest_off+1)
381 else loop (src_off+1) dest_off
382
383 -- run two loops in sequence,
384 -- think of it as: loop1 >> loop2
385 sequenceLoops :: ImperativeLoop acc1
386 -> ImperativeLoop acc2
387 -> ImperativeLoop (PairS acc1 acc2)
388 sequenceLoops loop1 loop2 src dest len0 = do
389 (acc1 :*: off1 :*: len1) <- loop1 src dest len0
390 (acc2 :*: off2 :*: len2) <-
391 let src' = dest `plusPtr` off1
392 dest' = src' -- note that we are using dest == src
393 -- for the second loop as we are
394 -- mutating the dest array in-place!
395 in loop2 src' dest' len1
396 return ((acc1 :*: acc2) :*: off1 + off2 :*: len2)
397
398 -- TODO: prove that this is associative! (I think it is)
399 -- since we can't be sure how the RULES will combine loops.
400
401 #if defined(__GLASGOW_HASKELL__)
402
403 {-# INLINE [1] doUpLoop #-}
404 {-# INLINE [1] doDownLoop #-}
405 {-# INLINE [1] doNoAccLoop #-}
406 {-# INLINE [1] doMapLoop #-}
407 {-# INLINE [1] doFilterLoop #-}
408
409 {-# INLINE [1] loopWrapper #-}
410 {-# INLINE [1] sequenceLoops #-}
411
412 {-# INLINE [1] fuseAccAccEFL #-}
413 {-# INLINE [1] fuseAccNoAccEFL #-}
414 {-# INLINE [1] fuseNoAccAccEFL #-}
415 {-# INLINE [1] fuseNoAccNoAccEFL #-}
416 {-# INLINE [1] fuseMapAccEFL #-}
417 {-# INLINE [1] fuseAccMapEFL #-}
418 {-# INLINE [1] fuseMapNoAccEFL #-}
419 {-# INLINE [1] fuseNoAccMapEFL #-}
420 {-# INLINE [1] fuseMapMapEFL #-}
421 {-# INLINE [1] fuseAccFilterEFL #-}
422 {-# INLINE [1] fuseFilterAccEFL #-}
423 {-# INLINE [1] fuseNoAccFilterEFL #-}
424 {-# INLINE [1] fuseFilterNoAccEFL #-}
425 {-# INLINE [1] fuseFilterFilterEFL #-}
426 {-# INLINE [1] fuseMapFilterEFL #-}
427 {-# INLINE [1] fuseFilterMapEFL #-}
428
429 #endif
430
431 {-# RULES
432
433 "loopArr/loopSndAcc" forall x.
434 loopArr (loopSndAcc x) = loopArr x
435
436 "seq/NoAcc" forall (u::NoAcc) e.
437 u `seq` e = e
438
439 "loop/loop wrapper elimination" forall loop1 loop2 arr.
440 loopWrapper loop2 (loopArr (loopWrapper loop1 arr)) =
441 loopSndAcc (loopWrapper (sequenceLoops loop1 loop2) arr)
442
443 --
444 -- n.b in the following, when reading n/m fusion, recall sequenceLoops
445 -- is monadic, so its really n >> m fusion (i.e. m.n), not n . m fusion.
446 --
447
448 "up/up loop fusion" forall f1 f2 acc1 acc2.
449 sequenceLoops (doUpLoop f1 acc1) (doUpLoop f2 acc2) =
450 doUpLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)
451
452 "map/map loop fusion" forall f1 f2 acc1 acc2.
453 sequenceLoops (doMapLoop f1 acc1) (doMapLoop f2 acc2) =
454 doMapLoop (f1 `fuseMapMapEFL` f2) (acc1 :*: acc2)
455
456 "filter/filter loop fusion" forall f1 f2 acc1 acc2.
457 sequenceLoops (doFilterLoop f1 acc1) (doFilterLoop f2 acc2) =
458 doFilterLoop (f1 `fuseFilterFilterEFL` f2) (acc1 :*: acc2)
459
460 "map/filter loop fusion" forall f1 f2 acc1 acc2.
461 sequenceLoops (doMapLoop f1 acc1) (doFilterLoop f2 acc2) =
462 doNoAccLoop (f1 `fuseMapFilterEFL` f2) (acc1 :*: acc2)
463
464 "filter/map loop fusion" forall f1 f2 acc1 acc2.
465 sequenceLoops (doFilterLoop f1 acc1) (doMapLoop f2 acc2) =
466 doNoAccLoop (f1 `fuseFilterMapEFL` f2) (acc1 :*: acc2)
467
468 "map/up loop fusion" forall f1 f2 acc1 acc2.
469 sequenceLoops (doMapLoop f1 acc1) (doUpLoop f2 acc2) =
470 doUpLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)
471
472 "up/map loop fusion" forall f1 f2 acc1 acc2.
473 sequenceLoops (doUpLoop f1 acc1) (doMapLoop f2 acc2) =
474 doUpLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)
475
476 "filter/up loop fusion" forall f1 f2 acc1 acc2.
477 sequenceLoops (doFilterLoop f1 acc1) (doUpLoop f2 acc2) =
478 doUpLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)
479
480 "up/filter loop fusion" forall f1 f2 acc1 acc2.
481 sequenceLoops (doUpLoop f1 acc1) (doFilterLoop f2 acc2) =
482 doUpLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)
483
484 "down/down loop fusion" forall f1 f2 acc1 acc2.
485 sequenceLoops (doDownLoop f1 acc1) (doDownLoop f2 acc2) =
486 doDownLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)
487
488 "map/down fusion" forall f1 f2 acc1 acc2.
489 sequenceLoops (doMapLoop f1 acc1) (doDownLoop f2 acc2) =
490 doDownLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)
491
492 "down/map loop fusion" forall f1 f2 acc1 acc2.
493 sequenceLoops (doDownLoop f1 acc1) (doMapLoop f2 acc2) =
494 doDownLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)
495
496 "filter/down fusion" forall f1 f2 acc1 acc2.
497 sequenceLoops (doFilterLoop f1 acc1) (doDownLoop f2 acc2) =
498 doDownLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)
499
500 "down/filter loop fusion" forall f1 f2 acc1 acc2.
501 sequenceLoops (doDownLoop f1 acc1) (doFilterLoop f2 acc2) =
502 doDownLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)
503
504 "noAcc/noAcc loop fusion" forall f1 f2 acc1 acc2.
505 sequenceLoops (doNoAccLoop f1 acc1) (doNoAccLoop f2 acc2) =
506 doNoAccLoop (f1 `fuseNoAccNoAccEFL` f2) (acc1 :*: acc2)
507
508 "noAcc/up loop fusion" forall f1 f2 acc1 acc2.
509 sequenceLoops (doNoAccLoop f1 acc1) (doUpLoop f2 acc2) =
510 doUpLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)
511
512 "up/noAcc loop fusion" forall f1 f2 acc1 acc2.
513 sequenceLoops (doUpLoop f1 acc1) (doNoAccLoop f2 acc2) =
514 doUpLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)
515
516 "map/noAcc loop fusion" forall f1 f2 acc1 acc2.
517 sequenceLoops (doMapLoop f1 acc1) (doNoAccLoop f2 acc2) =
518 doNoAccLoop (f1 `fuseMapNoAccEFL` f2) (acc1 :*: acc2)
519
520 "noAcc/map loop fusion" forall f1 f2 acc1 acc2.
521 sequenceLoops (doNoAccLoop f1 acc1) (doMapLoop f2 acc2) =
522 doNoAccLoop (f1 `fuseNoAccMapEFL` f2) (acc1 :*: acc2)
523
524 "filter/noAcc loop fusion" forall f1 f2 acc1 acc2.
525 sequenceLoops (doFilterLoop f1 acc1) (doNoAccLoop f2 acc2) =
526 doNoAccLoop (f1 `fuseFilterNoAccEFL` f2) (acc1 :*: acc2)
527
528 "noAcc/filter loop fusion" forall f1 f2 acc1 acc2.
529 sequenceLoops (doNoAccLoop f1 acc1) (doFilterLoop f2 acc2) =
530 doNoAccLoop (f1 `fuseNoAccFilterEFL` f2) (acc1 :*: acc2)
531
532 "noAcc/down loop fusion" forall f1 f2 acc1 acc2.
533 sequenceLoops (doNoAccLoop f1 acc1) (doDownLoop f2 acc2) =
534 doDownLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)
535
536 "down/noAcc loop fusion" forall f1 f2 acc1 acc2.
537 sequenceLoops (doDownLoop f1 acc1) (doNoAccLoop f2 acc2) =
538 doDownLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)
539
540 #-}
541
542 {-
543
544 up = up loop
545 down = down loop
546 map = map special case
547 filter = filter special case
548 noAcc = noAcc undirectional loop (unused)
549
550 heirarchy:
551 up down
552 ^ ^
553 \ /
554 noAcc
555 ^ ^
556 / \
557 map filter
558
559 each is a special case of the things above
560
561 so we get rules that combine things on the same level
562 and rules that combine things on different levels
563 to get something on the higher level
564
565 so all the cases:
566 up/up --> up fuseAccAccEFL
567 down/down --> down fuseAccAccEFL
568 noAcc/noAcc --> noAcc fuseNoAccNoAccEFL
569
570 noAcc/up --> up fuseNoAccAccEFL
571 up/noAcc --> up fuseAccNoAccEFL
572 noAcc/down --> down fuseNoAccAccEFL
573 down/noAcc --> down fuseAccNoAccEFL
574
575 and if we do the map, filter special cases then it adds a load more:
576
577 map/map --> map fuseMapMapEFL
578 filter/filter --> filter fuseFilterFilterEFL
579
580 map/filter --> noAcc fuseMapFilterEFL
581 filter/map --> noAcc fuseFilterMapEFL
582
583 map/noAcc --> noAcc fuseMapNoAccEFL
584 noAcc/map --> noAcc fuseNoAccMapEFL
585
586 map/up --> up fuseMapAccEFL
587 up/map --> up fuseAccMapEFL
588
589 map/down --> down fuseMapAccEFL
590 down/map --> down fuseAccMapEFL
591
592 filter/noAcc --> noAcc fuseNoAccFilterEFL
593 noAcc/filter --> noAcc fuseFilterNoAccEFL
594
595 filter/up --> up fuseFilterAccEFL
596 up/filter --> up fuseAccFilterEFL
597
598 filter/down --> down fuseFilterAccEFL
599 down/filter --> down fuseAccFilterEFL
600 -}
601
602 fuseAccAccEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
603 fuseAccAccEFL f g (acc1 :*: acc2) e1 =
604 case f acc1 e1 of
605 acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
606 acc1' :*: JustS e2 ->
607 case g acc2 e2 of
608 acc2' :*: res -> (acc1' :*: acc2') :*: res
609
610 fuseAccNoAccEFL :: AccEFL acc -> NoAccEFL -> AccEFL (PairS acc noAcc)
611 fuseAccNoAccEFL f g (acc :*: noAcc) e1 =
612 case f acc e1 of
613 acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
614 acc' :*: JustS e2 -> (acc' :*: noAcc) :*: g e2
615
616 fuseNoAccAccEFL :: NoAccEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
617 fuseNoAccAccEFL f g (noAcc :*: acc) e1 =
618 case f e1 of
619 NothingS -> (noAcc :*: acc) :*: NothingS
620 JustS e2 ->
621 case g acc e2 of
622 acc' :*: res -> (noAcc :*: acc') :*: res
623
624 fuseNoAccNoAccEFL :: NoAccEFL -> NoAccEFL -> NoAccEFL
625 fuseNoAccNoAccEFL f g e1 =
626 case f e1 of
627 NothingS -> NothingS
628 JustS e2 -> g e2
629
630 fuseMapAccEFL :: MapEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
631 fuseMapAccEFL f g (noAcc :*: acc) e1 =
632 case g acc (f e1) of
633 (acc' :*: res) -> (noAcc :*: acc') :*: res
634
635 fuseAccMapEFL :: AccEFL acc -> MapEFL -> AccEFL (PairS acc noAcc)
636 fuseAccMapEFL f g (acc :*: noAcc) e1 =
637 case f acc e1 of
638 (acc' :*: NothingS) -> (acc' :*: noAcc) :*: NothingS
639 (acc' :*: JustS e2) -> (acc' :*: noAcc) :*: JustS (g e2)
640
641 fuseMapMapEFL :: MapEFL -> MapEFL -> MapEFL
642 fuseMapMapEFL f g e1 = g (f e1) -- n.b. perfect fusion
643
644 fuseMapNoAccEFL :: MapEFL -> NoAccEFL -> NoAccEFL
645 fuseMapNoAccEFL f g e1 = g (f e1)
646
647 fuseNoAccMapEFL :: NoAccEFL -> MapEFL -> NoAccEFL
648 fuseNoAccMapEFL f g e1 =
649 case f e1 of
650 NothingS -> NothingS
651 JustS e2 -> JustS (g e2)
652
653 fuseAccFilterEFL :: AccEFL acc -> FilterEFL -> AccEFL (PairS acc noAcc)
654 fuseAccFilterEFL f g (acc :*: noAcc) e1 =
655 case f acc e1 of
656 acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
657 acc' :*: JustS e2 ->
658 case g e2 of
659 False -> (acc' :*: noAcc) :*: NothingS
660 True -> (acc' :*: noAcc) :*: JustS e2
661
662 fuseFilterAccEFL :: FilterEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
663 fuseFilterAccEFL f g (noAcc :*: acc) e1 =
664 case f e1 of
665 False -> (noAcc :*: acc) :*: NothingS
666 True ->
667 case g acc e1 of
668 acc' :*: res -> (noAcc :*: acc') :*: res
669
670 fuseNoAccFilterEFL :: NoAccEFL -> FilterEFL -> NoAccEFL
671 fuseNoAccFilterEFL f g e1 =
672 case f e1 of
673 NothingS -> NothingS
674 JustS e2 ->
675 case g e2 of
676 False -> NothingS
677 True -> JustS e2
678
679 fuseFilterNoAccEFL :: FilterEFL -> NoAccEFL -> NoAccEFL
680 fuseFilterNoAccEFL f g e1 =
681 case f e1 of
682 False -> NothingS
683 True -> g e1
684
685 fuseFilterFilterEFL :: FilterEFL -> FilterEFL -> FilterEFL
686 fuseFilterFilterEFL f g e1 = f e1 && g e1
687
688 fuseMapFilterEFL :: MapEFL -> FilterEFL -> NoAccEFL
689 fuseMapFilterEFL f g e1 =
690 case f e1 of
691 e2 -> case g e2 of
692 False -> NothingS
693 True -> JustS e2
694
695 fuseFilterMapEFL :: FilterEFL -> MapEFL -> NoAccEFL
696 fuseFilterMapEFL f g e1 =
697 case f e1 of
698 False -> NothingS
699 True -> JustS (g e1)
700