1 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}
3 -- Module : Data.ByteString.Fusion
5 -- Maintainer : dons@cse.unsw.edu.au
6 -- Stability : experimental
7 -- Portability : portable
9 -- Functional array fusion for ByteStrings.
11 -- Originally based on code from the Data Parallel Haskell project,
12 -- <http://www.cse.unsw.edu.au/~chak/project/dph>
16 module Data.ByteString.Fusion (
19 loopU, loopL, fuseEFL,
20 NoAcc(NoAcc), loopArr, loopAcc, loopSndAcc, unSP,
21 mapEFL, filterEFL, foldEFL, foldEFL', scanEFL, mapAccumEFL, mapIndexEFL,
23 -- ** Alternative Fusion stuff
24 -- | This replaces 'loopU' with 'loopUp'
25 -- and adds several further special cases of loops.
26 loopUp, loopDown, loopNoAcc, loopMap, loopFilter,
27 loopWrapper, sequenceLoops,
28 doUpLoop, doDownLoop, doNoAccLoop, doMapLoop, doFilterLoop,
30 -- | These are the special fusion cases for combining each loop form perfectly.
31 fuseAccAccEFL, fuseAccNoAccEFL, fuseNoAccAccEFL, fuseNoAccNoAccEFL,
32 fuseMapAccEFL, fuseAccMapEFL, fuseMapNoAccEFL, fuseNoAccMapEFL,
33 fuseMapMapEFL, fuseAccFilterEFL, fuseFilterAccEFL, fuseNoAccFilterEFL,
34 fuseFilterNoAccEFL, fuseFilterFilterEFL, fuseMapFilterEFL, fuseFilterMapEFL,
36 -- * Strict pairs and sums
41 import Data.ByteString.Base
43 import Foreign.ForeignPtr
45 import Foreign.Storable (Storable(..))
47 import Data.Word (Word8)
48 import System.IO.Unsafe (unsafePerformIO)
50 -- -----------------------------------------------------------------------------
52 -- Useful macros, until we have bang patterns
55 #define STRICT1(f) f a | a `seq` False = undefined
56 #define STRICT2(f) f a b | a `seq` b `seq` False = undefined
57 #define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
58 #define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined
59 #define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined
64 data PairS a b = !a :*: !b deriving (Eq,Ord,Show)
67 data MaybeS a = NothingS | JustS !a deriving (Eq,Ord,Show)
69 -- |Data type for accumulators which can be ignored. The rewrite rules rely on
70 -- the fact that no bottoms of this type are ever constructed; hence, we can
71 -- assume @(_ :: NoAcc) `seq` x = x@.
75 -- |Type of loop functions
76 type AccEFL acc = acc -> Word8 -> (PairS acc (MaybeS Word8))
77 type NoAccEFL = Word8 -> MaybeS Word8
78 type MapEFL = Word8 -> Word8
79 type FilterEFL = Word8 -> Bool
83 -- |Fuse to flat loop functions
84 fuseEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
85 fuseEFL f g (acc1 :*: acc2) e1 =
87 acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
90 acc2' :*: res -> (acc1' :*: acc2') :*: res
91 #if defined(__GLASGOW_HASKELL__)
92 {-# INLINE [1] fuseEFL #-}
95 -- | Special forms of loop arguments
97 -- * These are common special cases for the three function arguments of gen
98 -- and loop; we give them special names to make it easier to trigger RULES
99 -- applying in the special cases represented by these arguments. The
100 -- "INLINE [1]" makes sure that these functions are only inlined in the last
101 -- two simplifier phases.
103 -- * In the case where the accumulator is not needed, it is better to always
104 -- explicitly return a value `()', rather than just copy the input to the
105 -- output, as the former gives GHC better local information.
108 -- | Element function expressing a mapping only
109 #if !defined(LOOPNOACC_FUSION)
110 mapEFL :: (Word8 -> Word8) -> AccEFL NoAcc
111 mapEFL f = \_ e -> (NoAcc :*: (JustS $ f e))
113 mapEFL :: (Word8 -> Word8) -> NoAccEFL
114 mapEFL f = \e -> JustS (f e)
116 #if defined(__GLASGOW_HASKELL__)
117 {-# INLINE [1] mapEFL #-}
120 -- | Element function implementing a filter function only
121 #if !defined(LOOPNOACC_FUSION)
122 filterEFL :: (Word8 -> Bool) -> AccEFL NoAcc
123 filterEFL p = \_ e -> if p e then (NoAcc :*: JustS e) else (NoAcc :*: NothingS)
125 filterEFL :: (Word8 -> Bool) -> NoAccEFL
126 filterEFL p = \e -> if p e then JustS e else NothingS
129 #if defined(__GLASGOW_HASKELL__)
130 {-# INLINE [1] filterEFL #-}
133 -- |Element function expressing a reduction only
134 foldEFL :: (acc -> Word8 -> acc) -> AccEFL acc
135 foldEFL f = \a e -> (f a e :*: NothingS)
136 #if defined(__GLASGOW_HASKELL__)
137 {-# INLINE [1] foldEFL #-}
140 -- | A strict foldEFL.
141 foldEFL' :: (acc -> Word8 -> acc) -> AccEFL acc
142 foldEFL' f = \a e -> let a' = f a e in a' `seq` (a' :*: NothingS)
143 #if defined(__GLASGOW_HASKELL__)
144 {-# INLINE [1] foldEFL' #-}
147 -- | Element function expressing a prefix reduction only
149 scanEFL :: (Word8 -> Word8 -> Word8) -> AccEFL Word8
150 scanEFL f = \a e -> (f a e :*: JustS a)
151 #if defined(__GLASGOW_HASKELL__)
152 {-# INLINE [1] scanEFL #-}
155 -- | Element function implementing a map and fold
157 mapAccumEFL :: (acc -> Word8 -> (acc, Word8)) -> AccEFL acc
158 mapAccumEFL f = \a e -> case f a e of (a', e') -> (a' :*: JustS e')
159 #if defined(__GLASGOW_HASKELL__)
160 {-# INLINE [1] mapAccumEFL #-}
163 -- | Element function implementing a map with index
165 mapIndexEFL :: (Int -> Word8 -> Word8) -> AccEFL Int
166 mapIndexEFL f = \i e -> let i' = i+1 in i' `seq` (i' :*: JustS (f i e))
167 #if defined(__GLASGOW_HASKELL__)
168 {-# INLINE [1] mapIndexEFL #-}
171 -- | Projection functions that are fusion friendly (as in, we determine when
173 loopArr :: (PairS acc arr) -> arr
174 loopArr (_ :*: arr) = arr
175 #if defined(__GLASGOW_HASKELL__)
176 {-# INLINE [1] loopArr #-}
179 loopAcc :: (PairS acc arr) -> acc
180 loopAcc (acc :*: _) = acc
181 #if defined(__GLASGOW_HASKELL__)
182 {-# INLINE [1] loopAcc #-}
185 loopSndAcc :: (PairS (PairS acc1 acc2) arr) -> (PairS acc2 arr)
186 loopSndAcc ((_ :*: acc) :*: arr) = (acc :*: arr)
187 #if defined(__GLASGOW_HASKELL__)
188 {-# INLINE [1] loopSndAcc #-}
191 unSP :: (PairS acc arr) -> (acc, arr)
192 unSP (acc :*: arr) = (acc, arr)
193 #if defined(__GLASGOW_HASKELL__)
194 {-# INLINE [1] unSP #-}
197 ------------------------------------------------------------------------
199 -- Loop combinator and fusion rules for flat arrays
200 -- |Iteration over over ByteStrings
202 -- | Iteration over over ByteStrings
203 loopU :: AccEFL acc -- ^ mapping & folding, once per elem
204 -> acc -- ^ initial acc value
205 -> ByteString -- ^ input ByteString
206 -> (PairS acc ByteString)
208 loopU f start (PS z s i) = unsafePerformIO $ withForeignPtr z $ \a -> do
209 (ps, acc) <- createAndTrim' i $ \p -> do
210 (acc' :*: i') <- go (a `plusPtr` s) p start
218 trans a_off ma_off acc
219 | a_off >= i = return (acc :*: ma_off)
221 x <- peekByteOff p a_off
222 let (acc' :*: oe) = f acc x
223 ma_off' <- case oe of
224 NothingS -> return ma_off
225 JustS e -> do pokeByteOff ma ma_off e
227 trans (a_off+1) ma_off' acc'
229 #if defined(__GLASGOW_HASKELL__)
230 {-# INLINE [1] loopU #-}
235 "FPS loop/loop fusion!" forall em1 em2 start1 start2 arr.
236 loopU em2 start2 (loopArr (loopU em1 start1 arr)) =
237 loopSndAcc (loopU (em1 `fuseEFL` em2) (start1 :*: start2) arr)
242 -- Functional list/array fusion for lazy ByteStrings.
244 loopL :: AccEFL acc -- ^ mapping & folding, once per elem
245 -> acc -- ^ initial acc value
246 -> [ByteString] -- ^ input ByteString
247 -> PairS acc [ByteString]
249 where loop s [] = (s :*: [])
251 | l == 0 = (s'' :*: ys)
252 | otherwise = (s'' :*: y:ys)
253 where (s' :*: y@(PS _ _ l)) = loopU f s x -- avoid circular dep on P.null
254 (s'' :*: ys) = loop s' xs
256 #if defined(__GLASGOW_HASKELL__)
257 {-# INLINE [1] loopL #-}
262 "FPS lazy loop/loop fusion!" forall em1 em2 start1 start2 arr.
263 loopL em2 start2 (loopArr (loopL em1 start1 arr)) =
264 loopSndAcc (loopL (em1 `fuseEFL` em2) (start1 :*: start2) arr)
271 Alternate experimental formulation of loopU which partitions it into
272 an allocating wrapper and an imperitive array-mutating loop.
274 The point in doing this split is that we might be able to fuse multiple
275 loops into a single wrapper. This would save reallocating another buffer.
276 It should also give better cache locality by reusing the buffer.
278 Note that this stuff needs ghc-6.5 from May 26 or later for the RULES to
279 really work reliably.
283 loopUp :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
284 loopUp f a arr = loopWrapper (doUpLoop f a) arr
285 {-# INLINE loopUp #-}
287 loopDown :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
288 loopDown f a arr = loopWrapper (doDownLoop f a) arr
289 {-# INLINE loopDown #-}
291 loopNoAcc :: NoAccEFL -> ByteString -> PairS NoAcc ByteString
292 loopNoAcc f arr = loopWrapper (doNoAccLoop f NoAcc) arr
293 {-# INLINE loopNoAcc #-}
295 loopMap :: MapEFL -> ByteString -> PairS NoAcc ByteString
296 loopMap f arr = loopWrapper (doMapLoop f NoAcc) arr
297 {-# INLINE loopMap #-}
299 loopFilter :: FilterEFL -> ByteString -> PairS NoAcc ByteString
300 loopFilter f arr = loopWrapper (doFilterLoop f NoAcc) arr
301 {-# INLINE loopFilter #-}
303 -- The type of imperitive loops that fill in a destination array by
304 -- reading a source array. They may not fill in the whole of the dest
305 -- array if the loop is behaving as a filter, this is why we return
306 -- the length that was filled in. The loop may also accumulate some
307 -- value as it loops over the source array.
309 type ImperativeLoop acc =
310 Ptr Word8 -- pointer to the start of the source byte array
311 -> Ptr Word8 -- pointer to ther start of the destination byte array
312 -> Int -- length of the source byte array
313 -> IO (PairS (PairS acc Int) Int) -- result and offset, length of dest that was filled
315 loopWrapper :: ImperativeLoop acc -> ByteString -> PairS acc ByteString
316 loopWrapper body (PS srcFPtr srcOffset srcLen) = unsafePerformIO $
317 withForeignPtr srcFPtr $ \srcPtr -> do
318 (ps, acc) <- createAndTrim' srcLen $ \destPtr -> do
319 (acc :*: destOffset :*: destLen) <-
320 body (srcPtr `plusPtr` srcOffset) destPtr srcLen
321 return (destOffset, destLen, acc)
324 doUpLoop :: AccEFL acc -> acc -> ImperativeLoop acc
325 doUpLoop f acc0 src dest len = loop 0 0 acc0
327 loop src_off dest_off acc
328 | src_off >= len = return (acc :*: 0 :*: dest_off)
330 x <- peekByteOff src src_off
332 (acc' :*: NothingS) -> loop (src_off+1) dest_off acc'
333 (acc' :*: JustS x') -> pokeByteOff dest dest_off x'
334 >> loop (src_off+1) (dest_off+1) acc'
336 doDownLoop :: AccEFL acc -> acc -> ImperativeLoop acc
337 doDownLoop f acc0 src dest len = loop (len-1) (len-1) acc0
339 loop src_off dest_off acc
340 | src_off < 0 = return (acc :*: dest_off + 1 :*: len - (dest_off + 1))
342 x <- peekByteOff src src_off
344 (acc' :*: NothingS) -> loop (src_off-1) dest_off acc'
345 (acc' :*: JustS x') -> pokeByteOff dest dest_off x'
346 >> loop (src_off-1) (dest_off-1) acc'
348 doNoAccLoop :: NoAccEFL -> noAcc -> ImperativeLoop noAcc
349 doNoAccLoop f noAcc src dest len = loop 0 0
351 loop src_off dest_off
352 | src_off >= len = return (noAcc :*: 0 :*: dest_off)
354 x <- peekByteOff src src_off
356 NothingS -> loop (src_off+1) dest_off
357 JustS x' -> pokeByteOff dest dest_off x'
358 >> loop (src_off+1) (dest_off+1)
360 doMapLoop :: MapEFL -> noAcc -> ImperativeLoop noAcc
361 doMapLoop f noAcc src dest len = loop 0
364 | n >= len = return (noAcc :*: 0 :*: len)
366 x <- peekByteOff src n
367 pokeByteOff dest n (f x)
368 loop (n+1) -- offset always the same, only pass 1 arg
370 doFilterLoop :: FilterEFL -> noAcc -> ImperativeLoop noAcc
371 doFilterLoop f noAcc src dest len = loop 0 0
373 loop src_off dest_off
374 | src_off >= len = return (noAcc :*: 0 :*: dest_off)
376 x <- peekByteOff src src_off
378 then pokeByteOff dest dest_off x
379 >> loop (src_off+1) (dest_off+1)
380 else loop (src_off+1) dest_off
382 -- run two loops in sequence,
383 -- think of it as: loop1 >> loop2
384 sequenceLoops :: ImperativeLoop acc1
385 -> ImperativeLoop acc2
386 -> ImperativeLoop (PairS acc1 acc2)
387 sequenceLoops loop1 loop2 src dest len0 = do
388 (acc1 :*: off1 :*: len1) <- loop1 src dest len0
389 (acc2 :*: off2 :*: len2) <-
390 let src' = dest `plusPtr` off1
391 dest' = src' -- note that we are using dest == src
392 -- for the second loop as we are
393 -- mutating the dest array in-place!
394 in loop2 src' dest' len1
395 return ((acc1 :*: acc2) :*: off1 + off2 :*: len2)
397 -- TODO: prove that this is associative! (I think it is)
398 -- since we can't be sure how the RULES will combine loops.
400 #if defined(__GLASGOW_HASKELL__)
402 {-# INLINE [1] doUpLoop #-}
403 {-# INLINE [1] doDownLoop #-}
404 {-# INLINE [1] doNoAccLoop #-}
405 {-# INLINE [1] doMapLoop #-}
406 {-# INLINE [1] doFilterLoop #-}
408 {-# INLINE [1] loopWrapper #-}
409 {-# INLINE [1] sequenceLoops #-}
411 {-# INLINE [1] fuseAccAccEFL #-}
412 {-# INLINE [1] fuseAccNoAccEFL #-}
413 {-# INLINE [1] fuseNoAccAccEFL #-}
414 {-# INLINE [1] fuseNoAccNoAccEFL #-}
415 {-# INLINE [1] fuseMapAccEFL #-}
416 {-# INLINE [1] fuseAccMapEFL #-}
417 {-# INLINE [1] fuseMapNoAccEFL #-}
418 {-# INLINE [1] fuseNoAccMapEFL #-}
419 {-# INLINE [1] fuseMapMapEFL #-}
420 {-# INLINE [1] fuseAccFilterEFL #-}
421 {-# INLINE [1] fuseFilterAccEFL #-}
422 {-# INLINE [1] fuseNoAccFilterEFL #-}
423 {-# INLINE [1] fuseFilterNoAccEFL #-}
424 {-# INLINE [1] fuseFilterFilterEFL #-}
425 {-# INLINE [1] fuseMapFilterEFL #-}
426 {-# INLINE [1] fuseFilterMapEFL #-}
432 "FPS loopArr/loopSndAcc" forall x.
433 loopArr (loopSndAcc x) = loopArr x
435 "FPS seq/NoAcc" forall (u::NoAcc) e.
438 "FPS loop/loop wrapper elimination" forall loop1 loop2 arr.
439 loopWrapper loop2 (loopArr (loopWrapper loop1 arr)) =
440 loopSndAcc (loopWrapper (sequenceLoops loop1 loop2) arr)
443 -- n.b in the following, when reading n/m fusion, recall sequenceLoops
444 -- is monadic, so its really n >> m fusion (i.e. m.n), not n . m fusion.
447 "FPS up/up loop fusion" forall f1 f2 acc1 acc2.
448 sequenceLoops (doUpLoop f1 acc1) (doUpLoop f2 acc2) =
449 doUpLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)
451 "FPS map/map loop fusion" forall f1 f2 acc1 acc2.
452 sequenceLoops (doMapLoop f1 acc1) (doMapLoop f2 acc2) =
453 doMapLoop (f1 `fuseMapMapEFL` f2) (acc1 :*: acc2)
455 "FPS filter/filter loop fusion" forall f1 f2 acc1 acc2.
456 sequenceLoops (doFilterLoop f1 acc1) (doFilterLoop f2 acc2) =
457 doFilterLoop (f1 `fuseFilterFilterEFL` f2) (acc1 :*: acc2)
459 "FPS map/filter loop fusion" forall f1 f2 acc1 acc2.
460 sequenceLoops (doMapLoop f1 acc1) (doFilterLoop f2 acc2) =
461 doNoAccLoop (f1 `fuseMapFilterEFL` f2) (acc1 :*: acc2)
463 "FPS filter/map loop fusion" forall f1 f2 acc1 acc2.
464 sequenceLoops (doFilterLoop f1 acc1) (doMapLoop f2 acc2) =
465 doNoAccLoop (f1 `fuseFilterMapEFL` f2) (acc1 :*: acc2)
467 "FPS map/up loop fusion" forall f1 f2 acc1 acc2.
468 sequenceLoops (doMapLoop f1 acc1) (doUpLoop f2 acc2) =
469 doUpLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)
471 "FPS up/map loop fusion" forall f1 f2 acc1 acc2.
472 sequenceLoops (doUpLoop f1 acc1) (doMapLoop f2 acc2) =
473 doUpLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)
475 "FPS filter/up loop fusion" forall f1 f2 acc1 acc2.
476 sequenceLoops (doFilterLoop f1 acc1) (doUpLoop f2 acc2) =
477 doUpLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)
479 "FPS up/filter loop fusion" forall f1 f2 acc1 acc2.
480 sequenceLoops (doUpLoop f1 acc1) (doFilterLoop f2 acc2) =
481 doUpLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)
483 "FPS down/down loop fusion" forall f1 f2 acc1 acc2.
484 sequenceLoops (doDownLoop f1 acc1) (doDownLoop f2 acc2) =
485 doDownLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)
487 "FPS map/down fusion" forall f1 f2 acc1 acc2.
488 sequenceLoops (doMapLoop f1 acc1) (doDownLoop f2 acc2) =
489 doDownLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)
491 "FPS down/map loop fusion" forall f1 f2 acc1 acc2.
492 sequenceLoops (doDownLoop f1 acc1) (doMapLoop f2 acc2) =
493 doDownLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)
495 "FPS filter/down fusion" forall f1 f2 acc1 acc2.
496 sequenceLoops (doFilterLoop f1 acc1) (doDownLoop f2 acc2) =
497 doDownLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)
499 "FPS down/filter loop fusion" forall f1 f2 acc1 acc2.
500 sequenceLoops (doDownLoop f1 acc1) (doFilterLoop f2 acc2) =
501 doDownLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)
503 "FPS noAcc/noAcc loop fusion" forall f1 f2 acc1 acc2.
504 sequenceLoops (doNoAccLoop f1 acc1) (doNoAccLoop f2 acc2) =
505 doNoAccLoop (f1 `fuseNoAccNoAccEFL` f2) (acc1 :*: acc2)
507 "FPS noAcc/up loop fusion" forall f1 f2 acc1 acc2.
508 sequenceLoops (doNoAccLoop f1 acc1) (doUpLoop f2 acc2) =
509 doUpLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)
511 "FPS up/noAcc loop fusion" forall f1 f2 acc1 acc2.
512 sequenceLoops (doUpLoop f1 acc1) (doNoAccLoop f2 acc2) =
513 doUpLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)
515 "FPS map/noAcc loop fusion" forall f1 f2 acc1 acc2.
516 sequenceLoops (doMapLoop f1 acc1) (doNoAccLoop f2 acc2) =
517 doNoAccLoop (f1 `fuseMapNoAccEFL` f2) (acc1 :*: acc2)
519 "FPS noAcc/map loop fusion" forall f1 f2 acc1 acc2.
520 sequenceLoops (doNoAccLoop f1 acc1) (doMapLoop f2 acc2) =
521 doNoAccLoop (f1 `fuseNoAccMapEFL` f2) (acc1 :*: acc2)
523 "FPS filter/noAcc loop fusion" forall f1 f2 acc1 acc2.
524 sequenceLoops (doFilterLoop f1 acc1) (doNoAccLoop f2 acc2) =
525 doNoAccLoop (f1 `fuseFilterNoAccEFL` f2) (acc1 :*: acc2)
527 "FPS noAcc/filter loop fusion" forall f1 f2 acc1 acc2.
528 sequenceLoops (doNoAccLoop f1 acc1) (doFilterLoop f2 acc2) =
529 doNoAccLoop (f1 `fuseNoAccFilterEFL` f2) (acc1 :*: acc2)
531 "FPS noAcc/down loop fusion" forall f1 f2 acc1 acc2.
532 sequenceLoops (doNoAccLoop f1 acc1) (doDownLoop f2 acc2) =
533 doDownLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)
535 "FPS down/noAcc loop fusion" forall f1 f2 acc1 acc2.
536 sequenceLoops (doDownLoop f1 acc1) (doNoAccLoop f2 acc2) =
537 doDownLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)
545 map = map special case
546 filter = filter special case
547 noAcc = noAcc undirectional loop (unused)
558 each is a special case of the things above
560 so we get rules that combine things on the same level
561 and rules that combine things on different levels
562 to get something on the higher level
565 up/up --> up fuseAccAccEFL
566 down/down --> down fuseAccAccEFL
567 noAcc/noAcc --> noAcc fuseNoAccNoAccEFL
569 noAcc/up --> up fuseNoAccAccEFL
570 up/noAcc --> up fuseAccNoAccEFL
571 noAcc/down --> down fuseNoAccAccEFL
572 down/noAcc --> down fuseAccNoAccEFL
574 and if we do the map, filter special cases then it adds a load more:
576 map/map --> map fuseMapMapEFL
577 filter/filter --> filter fuseFilterFilterEFL
579 map/filter --> noAcc fuseMapFilterEFL
580 filter/map --> noAcc fuseFilterMapEFL
582 map/noAcc --> noAcc fuseMapNoAccEFL
583 noAcc/map --> noAcc fuseNoAccMapEFL
585 map/up --> up fuseMapAccEFL
586 up/map --> up fuseAccMapEFL
588 map/down --> down fuseMapAccEFL
589 down/map --> down fuseAccMapEFL
591 filter/noAcc --> noAcc fuseNoAccFilterEFL
592 noAcc/filter --> noAcc fuseFilterNoAccEFL
594 filter/up --> up fuseFilterAccEFL
595 up/filter --> up fuseAccFilterEFL
597 filter/down --> down fuseFilterAccEFL
598 down/filter --> down fuseAccFilterEFL
601 fuseAccAccEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
602 fuseAccAccEFL f g (acc1 :*: acc2) e1 =
604 acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
605 acc1' :*: JustS e2 ->
607 acc2' :*: res -> (acc1' :*: acc2') :*: res
609 fuseAccNoAccEFL :: AccEFL acc -> NoAccEFL -> AccEFL (PairS acc noAcc)
610 fuseAccNoAccEFL f g (acc :*: noAcc) e1 =
612 acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
613 acc' :*: JustS e2 -> (acc' :*: noAcc) :*: g e2
615 fuseNoAccAccEFL :: NoAccEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
616 fuseNoAccAccEFL f g (noAcc :*: acc) e1 =
618 NothingS -> (noAcc :*: acc) :*: NothingS
621 acc' :*: res -> (noAcc :*: acc') :*: res
623 fuseNoAccNoAccEFL :: NoAccEFL -> NoAccEFL -> NoAccEFL
624 fuseNoAccNoAccEFL f g e1 =
629 fuseMapAccEFL :: MapEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
630 fuseMapAccEFL f g (noAcc :*: acc) e1 =
632 (acc' :*: res) -> (noAcc :*: acc') :*: res
634 fuseAccMapEFL :: AccEFL acc -> MapEFL -> AccEFL (PairS acc noAcc)
635 fuseAccMapEFL f g (acc :*: noAcc) e1 =
637 (acc' :*: NothingS) -> (acc' :*: noAcc) :*: NothingS
638 (acc' :*: JustS e2) -> (acc' :*: noAcc) :*: JustS (g e2)
640 fuseMapMapEFL :: MapEFL -> MapEFL -> MapEFL
641 fuseMapMapEFL f g e1 = g (f e1) -- n.b. perfect fusion
643 fuseMapNoAccEFL :: MapEFL -> NoAccEFL -> NoAccEFL
644 fuseMapNoAccEFL f g e1 = g (f e1)
646 fuseNoAccMapEFL :: NoAccEFL -> MapEFL -> NoAccEFL
647 fuseNoAccMapEFL f g e1 =
650 JustS e2 -> JustS (g e2)
652 fuseAccFilterEFL :: AccEFL acc -> FilterEFL -> AccEFL (PairS acc noAcc)
653 fuseAccFilterEFL f g (acc :*: noAcc) e1 =
655 acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
658 False -> (acc' :*: noAcc) :*: NothingS
659 True -> (acc' :*: noAcc) :*: JustS e2
661 fuseFilterAccEFL :: FilterEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
662 fuseFilterAccEFL f g (noAcc :*: acc) e1 =
664 False -> (noAcc :*: acc) :*: NothingS
667 acc' :*: res -> (noAcc :*: acc') :*: res
669 fuseNoAccFilterEFL :: NoAccEFL -> FilterEFL -> NoAccEFL
670 fuseNoAccFilterEFL f g e1 =
678 fuseFilterNoAccEFL :: FilterEFL -> NoAccEFL -> NoAccEFL
679 fuseFilterNoAccEFL f g e1 =
684 fuseFilterFilterEFL :: FilterEFL -> FilterEFL -> FilterEFL
685 fuseFilterFilterEFL f g e1 = f e1 && g e1
687 fuseMapFilterEFL :: MapEFL -> FilterEFL -> NoAccEFL
688 fuseMapFilterEFL f g e1 =
694 fuseFilterMapEFL :: FilterEFL -> MapEFL -> NoAccEFL
695 fuseFilterMapEFL f g e1 =