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, requires ffi and cpp
8 -- Tested with : GHC 6.4.1 and Hugs March 2005
13 -- | Functional array fusion for ByteStrings.
15 -- Originally based on code from the Data Parallel Haskell project,
16 -- <http://www.cse.unsw.edu.au/~chak/project/dph>
18 module Data.ByteString.Fusion (
21 loopU, loopL, fuseEFL,
22 NoAcc(NoAcc), loopArr, loopAcc, loopSndAcc, unSP,
23 mapEFL, filterEFL, foldEFL, foldEFL', scanEFL, mapAccumEFL, mapIndexEFL,
25 -- ** Alternative Fusion stuff
26 -- | This replaces 'loopU' with 'loopUp'
27 -- and adds several further special cases of loops.
28 loopUp, loopDown, loopNoAcc, loopMap, loopFilter,
29 loopWrapper, sequenceLoops,
30 doUpLoop, doDownLoop, doNoAccLoop, doMapLoop, doFilterLoop,
32 -- | These are the special fusion cases for combining each loop form perfectly.
33 fuseAccAccEFL, fuseAccNoAccEFL, fuseNoAccAccEFL, fuseNoAccNoAccEFL,
34 fuseMapAccEFL, fuseAccMapEFL, fuseMapNoAccEFL, fuseNoAccMapEFL,
35 fuseMapMapEFL, fuseAccFilterEFL, fuseFilterAccEFL, fuseNoAccFilterEFL,
36 fuseFilterNoAccEFL, fuseFilterFilterEFL, fuseMapFilterEFL, fuseFilterMapEFL,
38 -- * Strict pairs and sums
43 import Data.ByteString.Base
45 import Foreign.ForeignPtr
47 import Foreign.Storable (Storable(..))
49 import Data.Word (Word8)
50 import System.IO.Unsafe (unsafePerformIO)
52 -- -----------------------------------------------------------------------------
54 -- Useful macros, until we have bang patterns
57 #define STRICT1(f) f a | a `seq` False = undefined
58 #define STRICT2(f) f a b | a `seq` b `seq` False = undefined
59 #define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
60 #define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined
61 #define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined
66 data PairS a b = !a :*: !b deriving (Eq,Ord,Show)
69 data MaybeS a = NothingS | JustS !a deriving (Eq,Ord,Show)
71 -- |Data type for accumulators which can be ignored. The rewrite rules rely on
72 -- the fact that no bottoms of this type are ever constructed; hence, we can
73 -- assume @(_ :: NoAcc) `seq` x = x@.
77 -- |Type of loop functions
78 type AccEFL acc = acc -> Word8 -> (PairS acc (MaybeS Word8))
79 type NoAccEFL = Word8 -> MaybeS Word8
80 type MapEFL = Word8 -> Word8
81 type FilterEFL = Word8 -> Bool
85 -- |Fuse to flat loop functions
86 fuseEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
87 fuseEFL f g (acc1 :*: acc2) e1 =
89 acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
92 acc2' :*: res -> (acc1' :*: acc2') :*: res
93 #if defined(__GLASGOW_HASKELL__)
94 {-# INLINE [1] fuseEFL #-}
97 -- | Special forms of loop arguments
99 -- * These are common special cases for the three function arguments of gen
100 -- and loop; we give them special names to make it easier to trigger RULES
101 -- applying in the special cases represented by these arguments. The
102 -- "INLINE [1]" makes sure that these functions are only inlined in the last
103 -- two simplifier phases.
105 -- * In the case where the accumulator is not needed, it is better to always
106 -- explicitly return a value `()', rather than just copy the input to the
107 -- output, as the former gives GHC better local information.
110 -- | Element function expressing a mapping only
111 #if !defined(LOOPNOACC_FUSION)
112 mapEFL :: (Word8 -> Word8) -> AccEFL NoAcc
113 mapEFL f = \_ e -> (NoAcc :*: (JustS $ f e))
115 mapEFL :: (Word8 -> Word8) -> NoAccEFL
116 mapEFL f = \e -> JustS (f e)
118 #if defined(__GLASGOW_HASKELL__)
119 {-# INLINE [1] mapEFL #-}
122 -- | Element function implementing a filter function only
123 #if !defined(LOOPNOACC_FUSION)
124 filterEFL :: (Word8 -> Bool) -> AccEFL NoAcc
125 filterEFL p = \_ e -> if p e then (NoAcc :*: JustS e) else (NoAcc :*: NothingS)
127 filterEFL :: (Word8 -> Bool) -> NoAccEFL
128 filterEFL p = \e -> if p e then JustS e else NothingS
131 #if defined(__GLASGOW_HASKELL__)
132 {-# INLINE [1] filterEFL #-}
135 -- |Element function expressing a reduction only
136 foldEFL :: (acc -> Word8 -> acc) -> AccEFL acc
137 foldEFL f = \a e -> (f a e :*: NothingS)
138 #if defined(__GLASGOW_HASKELL__)
139 {-# INLINE [1] foldEFL #-}
142 -- | A strict foldEFL.
143 foldEFL' :: (acc -> Word8 -> acc) -> AccEFL acc
144 foldEFL' f = \a e -> let a' = f a e in a' `seq` (a' :*: NothingS)
145 #if defined(__GLASGOW_HASKELL__)
146 {-# INLINE [1] foldEFL' #-}
149 -- | Element function expressing a prefix reduction only
151 scanEFL :: (Word8 -> Word8 -> Word8) -> AccEFL Word8
152 scanEFL f = \a e -> (f a e :*: JustS a)
153 #if defined(__GLASGOW_HASKELL__)
154 {-# INLINE [1] scanEFL #-}
157 -- | Element function implementing a map and fold
159 mapAccumEFL :: (acc -> Word8 -> (acc, Word8)) -> AccEFL acc
160 mapAccumEFL f = \a e -> case f a e of (a', e') -> (a' :*: JustS e')
161 #if defined(__GLASGOW_HASKELL__)
162 {-# INLINE [1] mapAccumEFL #-}
165 -- | Element function implementing a map with index
167 mapIndexEFL :: (Int -> Word8 -> Word8) -> AccEFL Int
168 mapIndexEFL f = \i e -> let i' = i+1 in i' `seq` (i' :*: JustS (f i e))
169 #if defined(__GLASGOW_HASKELL__)
170 {-# INLINE [1] mapIndexEFL #-}
173 -- | Projection functions that are fusion friendly (as in, we determine when
175 loopArr :: (PairS acc arr) -> arr
176 loopArr (_ :*: arr) = arr
177 #if defined(__GLASGOW_HASKELL__)
178 {-# INLINE [1] loopArr #-}
181 loopAcc :: (PairS acc arr) -> acc
182 loopAcc (acc :*: _) = acc
183 #if defined(__GLASGOW_HASKELL__)
184 {-# INLINE [1] loopAcc #-}
187 loopSndAcc :: (PairS (PairS acc1 acc2) arr) -> (PairS acc2 arr)
188 loopSndAcc ((_ :*: acc) :*: arr) = (acc :*: arr)
189 #if defined(__GLASGOW_HASKELL__)
190 {-# INLINE [1] loopSndAcc #-}
193 unSP :: (PairS acc arr) -> (acc, arr)
194 unSP (acc :*: arr) = (acc, arr)
195 #if defined(__GLASGOW_HASKELL__)
196 {-# INLINE [1] unSP #-}
199 ------------------------------------------------------------------------
201 -- Loop combinator and fusion rules for flat arrays
202 -- |Iteration over over ByteStrings
204 -- | Iteration over over ByteStrings
205 loopU :: AccEFL acc -- ^ mapping & folding, once per elem
206 -> acc -- ^ initial acc value
207 -> ByteString -- ^ input ByteString
208 -> (PairS acc ByteString)
210 loopU f start (PS z s i) = unsafePerformIO $ withForeignPtr z $ \a -> do
211 (ps, acc) <- createAndTrim' i $ \p -> do
212 (acc' :*: i') <- go (a `plusPtr` s) p start
220 trans a_off ma_off acc
221 | a_off >= i = return (acc :*: ma_off)
223 x <- peekByteOff p a_off
224 let (acc' :*: oe) = f acc x
225 ma_off' <- case oe of
226 NothingS -> return ma_off
227 JustS e -> do pokeByteOff ma ma_off e
229 trans (a_off+1) ma_off' acc'
231 #if defined(__GLASGOW_HASKELL__)
232 {-# INLINE [1] loopU #-}
237 "FPS loop/loop fusion!" forall em1 em2 start1 start2 arr.
238 loopU em2 start2 (loopArr (loopU em1 start1 arr)) =
239 loopSndAcc (loopU (em1 `fuseEFL` em2) (start1 :*: start2) arr)
244 -- Functional list/array fusion for lazy ByteStrings.
246 loopL :: AccEFL acc -- ^ mapping & folding, once per elem
247 -> acc -- ^ initial acc value
248 -> [ByteString] -- ^ input ByteString
249 -> PairS acc [ByteString]
251 where loop s [] = (s :*: [])
253 | l == 0 = (s'' :*: ys)
254 | otherwise = (s'' :*: y:ys)
255 where (s' :*: y@(PS _ _ l)) = loopU f s x -- avoid circular dep on P.null
256 (s'' :*: ys) = loop s' xs
258 #if defined(__GLASGOW_HASKELL__)
259 {-# INLINE [1] loopL #-}
264 "FPS lazy loop/loop fusion!" forall em1 em2 start1 start2 arr.
265 loopL em2 start2 (loopArr (loopL em1 start1 arr)) =
266 loopSndAcc (loopL (em1 `fuseEFL` em2) (start1 :*: start2) arr)
273 Alternate experimental formulation of loopU which partitions it into
274 an allocating wrapper and an imperitive array-mutating loop.
276 The point in doing this split is that we might be able to fuse multiple
277 loops into a single wrapper. This would save reallocating another buffer.
278 It should also give better cache locality by reusing the buffer.
280 Note that this stuff needs ghc-6.5 from May 26 or later for the RULES to
281 really work reliably.
285 loopUp :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
286 loopUp f a arr = loopWrapper (doUpLoop f a) arr
287 {-# INLINE loopUp #-}
289 loopDown :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
290 loopDown f a arr = loopWrapper (doDownLoop f a) arr
291 {-# INLINE loopDown #-}
293 loopNoAcc :: NoAccEFL -> ByteString -> PairS NoAcc ByteString
294 loopNoAcc f arr = loopWrapper (doNoAccLoop f NoAcc) arr
295 {-# INLINE loopNoAcc #-}
297 loopMap :: MapEFL -> ByteString -> PairS NoAcc ByteString
298 loopMap f arr = loopWrapper (doMapLoop f NoAcc) arr
299 {-# INLINE loopMap #-}
301 loopFilter :: FilterEFL -> ByteString -> PairS NoAcc ByteString
302 loopFilter f arr = loopWrapper (doFilterLoop f NoAcc) arr
303 {-# INLINE loopFilter #-}
305 -- The type of imperitive loops that fill in a destination array by
306 -- reading a source array. They may not fill in the whole of the dest
307 -- array if the loop is behaving as a filter, this is why we return
308 -- the length that was filled in. The loop may also accumulate some
309 -- value as it loops over the source array.
311 type ImperativeLoop acc =
312 Ptr Word8 -- pointer to the start of the source byte array
313 -> Ptr Word8 -- pointer to ther start of the destination byte array
314 -> Int -- length of the source byte array
315 -> IO (PairS (PairS acc Int) Int) -- result and offset, length of dest that was filled
317 loopWrapper :: ImperativeLoop acc -> ByteString -> PairS acc ByteString
318 loopWrapper body (PS srcFPtr srcOffset srcLen) = unsafePerformIO $
319 withForeignPtr srcFPtr $ \srcPtr -> do
320 (ps, acc) <- createAndTrim' srcLen $ \destPtr -> do
321 (acc :*: destOffset :*: destLen) <-
322 body (srcPtr `plusPtr` srcOffset) destPtr srcLen
323 return (destOffset, destLen, acc)
326 doUpLoop :: AccEFL acc -> acc -> ImperativeLoop acc
327 doUpLoop f acc0 src dest len = loop 0 0 acc0
329 loop src_off dest_off acc
330 | src_off >= len = return (acc :*: 0 :*: dest_off)
332 x <- peekByteOff src src_off
334 (acc' :*: NothingS) -> loop (src_off+1) dest_off acc'
335 (acc' :*: JustS x') -> pokeByteOff dest dest_off x'
336 >> loop (src_off+1) (dest_off+1) acc'
338 doDownLoop :: AccEFL acc -> acc -> ImperativeLoop acc
339 doDownLoop f acc0 src dest len = loop (len-1) (len-1) acc0
341 loop src_off dest_off acc
342 | src_off < 0 = return (acc :*: dest_off + 1 :*: len - (dest_off + 1))
344 x <- peekByteOff src src_off
346 (acc' :*: NothingS) -> loop (src_off-1) dest_off acc'
347 (acc' :*: JustS x') -> pokeByteOff dest dest_off x'
348 >> loop (src_off-1) (dest_off-1) acc'
350 doNoAccLoop :: NoAccEFL -> noAcc -> ImperativeLoop noAcc
351 doNoAccLoop f noAcc src dest len = loop 0 0
353 loop src_off dest_off
354 | src_off >= len = return (noAcc :*: 0 :*: dest_off)
356 x <- peekByteOff src src_off
358 NothingS -> loop (src_off+1) dest_off
359 JustS x' -> pokeByteOff dest dest_off x'
360 >> loop (src_off+1) (dest_off+1)
362 doMapLoop :: MapEFL -> noAcc -> ImperativeLoop noAcc
363 doMapLoop f noAcc src dest len = loop 0
366 | n >= len = return (noAcc :*: 0 :*: len)
368 x <- peekByteOff src n
369 pokeByteOff dest n (f x)
370 loop (n+1) -- offset always the same, only pass 1 arg
372 doFilterLoop :: FilterEFL -> noAcc -> ImperativeLoop noAcc
373 doFilterLoop f noAcc src dest len = loop 0 0
375 loop src_off dest_off
376 | src_off >= len = return (noAcc :*: 0 :*: dest_off)
378 x <- peekByteOff src src_off
380 then pokeByteOff dest dest_off x
381 >> loop (src_off+1) (dest_off+1)
382 else loop (src_off+1) dest_off
384 -- run two loops in sequence,
385 -- think of it as: loop1 >> loop2
386 sequenceLoops :: ImperativeLoop acc1
387 -> ImperativeLoop acc2
388 -> ImperativeLoop (PairS acc1 acc2)
389 sequenceLoops loop1 loop2 src dest len0 = do
390 (acc1 :*: off1 :*: len1) <- loop1 src dest len0
391 (acc2 :*: off2 :*: len2) <-
392 let src' = dest `plusPtr` off1
393 dest' = src' -- note that we are using dest == src
394 -- for the second loop as we are
395 -- mutating the dest array in-place!
396 in loop2 src' dest' len1
397 return ((acc1 :*: acc2) :*: off1 + off2 :*: len2)
399 -- TODO: prove that this is associative! (I think it is)
400 -- since we can't be sure how the RULES will combine loops.
402 #if defined(__GLASGOW_HASKELL__)
404 {-# INLINE [1] doUpLoop #-}
405 {-# INLINE [1] doDownLoop #-}
406 {-# INLINE [1] doNoAccLoop #-}
407 {-# INLINE [1] doMapLoop #-}
408 {-# INLINE [1] doFilterLoop #-}
410 {-# INLINE [1] loopWrapper #-}
411 {-# INLINE [1] sequenceLoops #-}
413 {-# INLINE [1] fuseAccAccEFL #-}
414 {-# INLINE [1] fuseAccNoAccEFL #-}
415 {-# INLINE [1] fuseNoAccAccEFL #-}
416 {-# INLINE [1] fuseNoAccNoAccEFL #-}
417 {-# INLINE [1] fuseMapAccEFL #-}
418 {-# INLINE [1] fuseAccMapEFL #-}
419 {-# INLINE [1] fuseMapNoAccEFL #-}
420 {-# INLINE [1] fuseNoAccMapEFL #-}
421 {-# INLINE [1] fuseMapMapEFL #-}
422 {-# INLINE [1] fuseAccFilterEFL #-}
423 {-# INLINE [1] fuseFilterAccEFL #-}
424 {-# INLINE [1] fuseNoAccFilterEFL #-}
425 {-# INLINE [1] fuseFilterNoAccEFL #-}
426 {-# INLINE [1] fuseFilterFilterEFL #-}
427 {-# INLINE [1] fuseMapFilterEFL #-}
428 {-# INLINE [1] fuseFilterMapEFL #-}
434 "FPS loopArr/loopSndAcc" forall x.
435 loopArr (loopSndAcc x) = loopArr x
437 "FPS seq/NoAcc" forall (u::NoAcc) e.
440 "FPS loop/loop wrapper elimination" forall loop1 loop2 arr.
441 loopWrapper loop2 (loopArr (loopWrapper loop1 arr)) =
442 loopSndAcc (loopWrapper (sequenceLoops loop1 loop2) arr)
445 -- n.b in the following, when reading n/m fusion, recall sequenceLoops
446 -- is monadic, so its really n >> m fusion (i.e. m.n), not n . m fusion.
449 "FPS up/up loop fusion" forall f1 f2 acc1 acc2.
450 sequenceLoops (doUpLoop f1 acc1) (doUpLoop f2 acc2) =
451 doUpLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)
453 "FPS map/map loop fusion" forall f1 f2 acc1 acc2.
454 sequenceLoops (doMapLoop f1 acc1) (doMapLoop f2 acc2) =
455 doMapLoop (f1 `fuseMapMapEFL` f2) (acc1 :*: acc2)
457 "FPS filter/filter loop fusion" forall f1 f2 acc1 acc2.
458 sequenceLoops (doFilterLoop f1 acc1) (doFilterLoop f2 acc2) =
459 doFilterLoop (f1 `fuseFilterFilterEFL` f2) (acc1 :*: acc2)
461 "FPS map/filter loop fusion" forall f1 f2 acc1 acc2.
462 sequenceLoops (doMapLoop f1 acc1) (doFilterLoop f2 acc2) =
463 doNoAccLoop (f1 `fuseMapFilterEFL` f2) (acc1 :*: acc2)
465 "FPS filter/map loop fusion" forall f1 f2 acc1 acc2.
466 sequenceLoops (doFilterLoop f1 acc1) (doMapLoop f2 acc2) =
467 doNoAccLoop (f1 `fuseFilterMapEFL` f2) (acc1 :*: acc2)
469 "FPS map/up loop fusion" forall f1 f2 acc1 acc2.
470 sequenceLoops (doMapLoop f1 acc1) (doUpLoop f2 acc2) =
471 doUpLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)
473 "FPS up/map loop fusion" forall f1 f2 acc1 acc2.
474 sequenceLoops (doUpLoop f1 acc1) (doMapLoop f2 acc2) =
475 doUpLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)
477 "FPS filter/up loop fusion" forall f1 f2 acc1 acc2.
478 sequenceLoops (doFilterLoop f1 acc1) (doUpLoop f2 acc2) =
479 doUpLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)
481 "FPS up/filter loop fusion" forall f1 f2 acc1 acc2.
482 sequenceLoops (doUpLoop f1 acc1) (doFilterLoop f2 acc2) =
483 doUpLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)
485 "FPS down/down loop fusion" forall f1 f2 acc1 acc2.
486 sequenceLoops (doDownLoop f1 acc1) (doDownLoop f2 acc2) =
487 doDownLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)
489 "FPS map/down fusion" forall f1 f2 acc1 acc2.
490 sequenceLoops (doMapLoop f1 acc1) (doDownLoop f2 acc2) =
491 doDownLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)
493 "FPS down/map loop fusion" forall f1 f2 acc1 acc2.
494 sequenceLoops (doDownLoop f1 acc1) (doMapLoop f2 acc2) =
495 doDownLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)
497 "FPS filter/down fusion" forall f1 f2 acc1 acc2.
498 sequenceLoops (doFilterLoop f1 acc1) (doDownLoop f2 acc2) =
499 doDownLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)
501 "FPS down/filter loop fusion" forall f1 f2 acc1 acc2.
502 sequenceLoops (doDownLoop f1 acc1) (doFilterLoop f2 acc2) =
503 doDownLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)
505 "FPS noAcc/noAcc loop fusion" forall f1 f2 acc1 acc2.
506 sequenceLoops (doNoAccLoop f1 acc1) (doNoAccLoop f2 acc2) =
507 doNoAccLoop (f1 `fuseNoAccNoAccEFL` f2) (acc1 :*: acc2)
509 "FPS noAcc/up loop fusion" forall f1 f2 acc1 acc2.
510 sequenceLoops (doNoAccLoop f1 acc1) (doUpLoop f2 acc2) =
511 doUpLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)
513 "FPS up/noAcc loop fusion" forall f1 f2 acc1 acc2.
514 sequenceLoops (doUpLoop f1 acc1) (doNoAccLoop f2 acc2) =
515 doUpLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)
517 "FPS map/noAcc loop fusion" forall f1 f2 acc1 acc2.
518 sequenceLoops (doMapLoop f1 acc1) (doNoAccLoop f2 acc2) =
519 doNoAccLoop (f1 `fuseMapNoAccEFL` f2) (acc1 :*: acc2)
521 "FPS noAcc/map loop fusion" forall f1 f2 acc1 acc2.
522 sequenceLoops (doNoAccLoop f1 acc1) (doMapLoop f2 acc2) =
523 doNoAccLoop (f1 `fuseNoAccMapEFL` f2) (acc1 :*: acc2)
525 "FPS filter/noAcc loop fusion" forall f1 f2 acc1 acc2.
526 sequenceLoops (doFilterLoop f1 acc1) (doNoAccLoop f2 acc2) =
527 doNoAccLoop (f1 `fuseFilterNoAccEFL` f2) (acc1 :*: acc2)
529 "FPS noAcc/filter loop fusion" forall f1 f2 acc1 acc2.
530 sequenceLoops (doNoAccLoop f1 acc1) (doFilterLoop f2 acc2) =
531 doNoAccLoop (f1 `fuseNoAccFilterEFL` f2) (acc1 :*: acc2)
533 "FPS noAcc/down loop fusion" forall f1 f2 acc1 acc2.
534 sequenceLoops (doNoAccLoop f1 acc1) (doDownLoop f2 acc2) =
535 doDownLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)
537 "FPS down/noAcc loop fusion" forall f1 f2 acc1 acc2.
538 sequenceLoops (doDownLoop f1 acc1) (doNoAccLoop f2 acc2) =
539 doDownLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)
547 map = map special case
548 filter = filter special case
549 noAcc = noAcc undirectional loop (unused)
560 each is a special case of the things above
562 so we get rules that combine things on the same level
563 and rules that combine things on different levels
564 to get something on the higher level
567 up/up --> up fuseAccAccEFL
568 down/down --> down fuseAccAccEFL
569 noAcc/noAcc --> noAcc fuseNoAccNoAccEFL
571 noAcc/up --> up fuseNoAccAccEFL
572 up/noAcc --> up fuseAccNoAccEFL
573 noAcc/down --> down fuseNoAccAccEFL
574 down/noAcc --> down fuseAccNoAccEFL
576 and if we do the map, filter special cases then it adds a load more:
578 map/map --> map fuseMapMapEFL
579 filter/filter --> filter fuseFilterFilterEFL
581 map/filter --> noAcc fuseMapFilterEFL
582 filter/map --> noAcc fuseFilterMapEFL
584 map/noAcc --> noAcc fuseMapNoAccEFL
585 noAcc/map --> noAcc fuseNoAccMapEFL
587 map/up --> up fuseMapAccEFL
588 up/map --> up fuseAccMapEFL
590 map/down --> down fuseMapAccEFL
591 down/map --> down fuseAccMapEFL
593 filter/noAcc --> noAcc fuseNoAccFilterEFL
594 noAcc/filter --> noAcc fuseFilterNoAccEFL
596 filter/up --> up fuseFilterAccEFL
597 up/filter --> up fuseAccFilterEFL
599 filter/down --> down fuseFilterAccEFL
600 down/filter --> down fuseAccFilterEFL
603 fuseAccAccEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
604 fuseAccAccEFL f g (acc1 :*: acc2) e1 =
606 acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
607 acc1' :*: JustS e2 ->
609 acc2' :*: res -> (acc1' :*: acc2') :*: res
611 fuseAccNoAccEFL :: AccEFL acc -> NoAccEFL -> AccEFL (PairS acc noAcc)
612 fuseAccNoAccEFL f g (acc :*: noAcc) e1 =
614 acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
615 acc' :*: JustS e2 -> (acc' :*: noAcc) :*: g e2
617 fuseNoAccAccEFL :: NoAccEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
618 fuseNoAccAccEFL f g (noAcc :*: acc) e1 =
620 NothingS -> (noAcc :*: acc) :*: NothingS
623 acc' :*: res -> (noAcc :*: acc') :*: res
625 fuseNoAccNoAccEFL :: NoAccEFL -> NoAccEFL -> NoAccEFL
626 fuseNoAccNoAccEFL f g e1 =
631 fuseMapAccEFL :: MapEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
632 fuseMapAccEFL f g (noAcc :*: acc) e1 =
634 (acc' :*: res) -> (noAcc :*: acc') :*: res
636 fuseAccMapEFL :: AccEFL acc -> MapEFL -> AccEFL (PairS acc noAcc)
637 fuseAccMapEFL f g (acc :*: noAcc) e1 =
639 (acc' :*: NothingS) -> (acc' :*: noAcc) :*: NothingS
640 (acc' :*: JustS e2) -> (acc' :*: noAcc) :*: JustS (g e2)
642 fuseMapMapEFL :: MapEFL -> MapEFL -> MapEFL
643 fuseMapMapEFL f g e1 = g (f e1) -- n.b. perfect fusion
645 fuseMapNoAccEFL :: MapEFL -> NoAccEFL -> NoAccEFL
646 fuseMapNoAccEFL f g e1 = g (f e1)
648 fuseNoAccMapEFL :: NoAccEFL -> MapEFL -> NoAccEFL
649 fuseNoAccMapEFL f g e1 =
652 JustS e2 -> JustS (g e2)
654 fuseAccFilterEFL :: AccEFL acc -> FilterEFL -> AccEFL (PairS acc noAcc)
655 fuseAccFilterEFL f g (acc :*: noAcc) e1 =
657 acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
660 False -> (acc' :*: noAcc) :*: NothingS
661 True -> (acc' :*: noAcc) :*: JustS e2
663 fuseFilterAccEFL :: FilterEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
664 fuseFilterAccEFL f g (noAcc :*: acc) e1 =
666 False -> (noAcc :*: acc) :*: NothingS
669 acc' :*: res -> (noAcc :*: acc') :*: res
671 fuseNoAccFilterEFL :: NoAccEFL -> FilterEFL -> NoAccEFL
672 fuseNoAccFilterEFL f g e1 =
680 fuseFilterNoAccEFL :: FilterEFL -> NoAccEFL -> NoAccEFL
681 fuseFilterNoAccEFL f g e1 =
686 fuseFilterFilterEFL :: FilterEFL -> FilterEFL -> FilterEFL
687 fuseFilterFilterEFL f g e1 = f e1 && g e1
689 fuseMapFilterEFL :: MapEFL -> FilterEFL -> NoAccEFL
690 fuseMapFilterEFL f g e1 =
696 fuseFilterMapEFL :: FilterEFL -> MapEFL -> NoAccEFL
697 fuseFilterMapEFL f g e1 =