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
12 -- | Functional array fusion for ByteStrings.
14 -- Originally based on code from the Data Parallel Haskell project,
15 -- <http://www.cse.unsw.edu.au/~chak/project/dph>
17 module Data.ByteString.Fusion (
20 loopU, loopL, fuseEFL,
21 NoAcc(NoAcc), loopArr, loopAcc, loopSndAcc, unSP,
22 mapEFL, filterEFL, foldEFL, foldEFL', scanEFL, mapAccumEFL, mapIndexEFL,
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,
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,
37 -- * Strict pairs and sums
42 import Data.ByteString.Base
44 import Foreign.ForeignPtr
46 import Foreign.Storable (Storable(..))
48 import Data.Word (Word8)
49 import System.IO.Unsafe (unsafePerformIO)
51 -- -----------------------------------------------------------------------------
53 -- Useful macros, until we have bang patterns
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
65 data PairS a b = !a :*: !b deriving (Eq,Ord,Show)
68 data MaybeS a = NothingS | JustS !a deriving (Eq,Ord,Show)
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@.
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
84 -- |Fuse to flat loop functions
85 fuseEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
86 fuseEFL f g (acc1 :*: acc2) e1 =
88 acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
91 acc2' :*: res -> (acc1' :*: acc2') :*: res
92 #if defined(__GLASGOW_HASKELL__)
93 {-# INLINE [1] fuseEFL #-}
96 -- | Special forms of loop arguments
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.
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.
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))
114 mapEFL :: (Word8 -> Word8) -> NoAccEFL
115 mapEFL f = \e -> JustS (f e)
117 #if defined(__GLASGOW_HASKELL__)
118 {-# INLINE [1] mapEFL #-}
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)
126 filterEFL :: (Word8 -> Bool) -> NoAccEFL
127 filterEFL p = \e -> if p e then JustS e else NothingS
130 #if defined(__GLASGOW_HASKELL__)
131 {-# INLINE [1] filterEFL #-}
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 #-}
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' #-}
148 -- | Element function expressing a prefix reduction only
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 #-}
156 -- | Element function implementing a map and fold
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 #-}
164 -- | Element function implementing a map with index
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 #-}
172 -- | Projection functions that are fusion friendly (as in, we determine when
174 loopArr :: (PairS acc arr) -> arr
175 loopArr (_ :*: arr) = arr
176 #if defined(__GLASGOW_HASKELL__)
177 {-# INLINE [1] loopArr #-}
180 loopAcc :: (PairS acc arr) -> acc
181 loopAcc (acc :*: _) = acc
182 #if defined(__GLASGOW_HASKELL__)
183 {-# INLINE [1] loopAcc #-}
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 #-}
192 unSP :: (PairS acc arr) -> (acc, arr)
193 unSP (acc :*: arr) = (acc, arr)
194 #if defined(__GLASGOW_HASKELL__)
195 {-# INLINE [1] unSP #-}
198 ------------------------------------------------------------------------
200 -- Loop combinator and fusion rules for flat arrays
201 -- |Iteration over over ByteStrings
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)
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
219 trans a_off ma_off acc
220 | a_off >= i = return (acc :*: ma_off)
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
228 trans (a_off+1) ma_off' acc'
230 #if defined(__GLASGOW_HASKELL__)
231 {-# INLINE [1] loopU #-}
236 "FPS 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)
243 -- Functional list/array fusion for lazy ByteStrings.
245 loopL :: AccEFL acc -- ^ mapping & folding, once per elem
246 -> acc -- ^ initial acc value
247 -> [ByteString] -- ^ input ByteString
248 -> PairS acc [ByteString]
250 where loop s [] = (s :*: [])
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
257 #if defined(__GLASGOW_HASKELL__)
258 {-# INLINE [1] loopL #-}
263 "FPS 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)
272 Alternate experimental formulation of loopU which partitions it into
273 an allocating wrapper and an imperitive array-mutating loop.
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.
279 Note that this stuff needs ghc-6.5 from May 26 or later for the RULES to
280 really work reliably.
284 loopUp :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
285 loopUp f a arr = loopWrapper (doUpLoop f a) arr
286 {-# INLINE loopUp #-}
288 loopDown :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
289 loopDown f a arr = loopWrapper (doDownLoop f a) arr
290 {-# INLINE loopDown #-}
292 loopNoAcc :: NoAccEFL -> ByteString -> PairS NoAcc ByteString
293 loopNoAcc f arr = loopWrapper (doNoAccLoop f NoAcc) arr
294 {-# INLINE loopNoAcc #-}
296 loopMap :: MapEFL -> ByteString -> PairS NoAcc ByteString
297 loopMap f arr = loopWrapper (doMapLoop f NoAcc) arr
298 {-# INLINE loopMap #-}
300 loopFilter :: FilterEFL -> ByteString -> PairS NoAcc ByteString
301 loopFilter f arr = loopWrapper (doFilterLoop f NoAcc) arr
302 {-# INLINE loopFilter #-}
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.
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
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)
325 doUpLoop :: AccEFL acc -> acc -> ImperativeLoop acc
326 doUpLoop f acc0 src dest len = loop 0 0 acc0
328 loop src_off dest_off acc
329 | src_off >= len = return (acc :*: 0 :*: dest_off)
331 x <- peekByteOff src src_off
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'
337 doDownLoop :: AccEFL acc -> acc -> ImperativeLoop acc
338 doDownLoop f acc0 src dest len = loop (len-1) (len-1) acc0
340 loop src_off dest_off acc
341 | src_off < 0 = return (acc :*: dest_off + 1 :*: len - (dest_off + 1))
343 x <- peekByteOff src src_off
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'
349 doNoAccLoop :: NoAccEFL -> noAcc -> ImperativeLoop noAcc
350 doNoAccLoop f noAcc src dest len = loop 0 0
352 loop src_off dest_off
353 | src_off >= len = return (noAcc :*: 0 :*: dest_off)
355 x <- peekByteOff src src_off
357 NothingS -> loop (src_off+1) dest_off
358 JustS x' -> pokeByteOff dest dest_off x'
359 >> loop (src_off+1) (dest_off+1)
361 doMapLoop :: MapEFL -> noAcc -> ImperativeLoop noAcc
362 doMapLoop f noAcc src dest len = loop 0
365 | n >= len = return (noAcc :*: 0 :*: len)
367 x <- peekByteOff src n
368 pokeByteOff dest n (f x)
369 loop (n+1) -- offset always the same, only pass 1 arg
371 doFilterLoop :: FilterEFL -> noAcc -> ImperativeLoop noAcc
372 doFilterLoop f noAcc src dest len = loop 0 0
374 loop src_off dest_off
375 | src_off >= len = return (noAcc :*: 0 :*: dest_off)
377 x <- peekByteOff src src_off
379 then pokeByteOff dest dest_off x
380 >> loop (src_off+1) (dest_off+1)
381 else loop (src_off+1) dest_off
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)
398 -- TODO: prove that this is associative! (I think it is)
399 -- since we can't be sure how the RULES will combine loops.
401 #if defined(__GLASGOW_HASKELL__)
403 {-# INLINE [1] doUpLoop #-}
404 {-# INLINE [1] doDownLoop #-}
405 {-# INLINE [1] doNoAccLoop #-}
406 {-# INLINE [1] doMapLoop #-}
407 {-# INLINE [1] doFilterLoop #-}
409 {-# INLINE [1] loopWrapper #-}
410 {-# INLINE [1] sequenceLoops #-}
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 #-}
433 "FPS loopArr/loopSndAcc" forall x.
434 loopArr (loopSndAcc x) = loopArr x
436 "FPS seq/NoAcc" forall (u::NoAcc) e.
439 "FPS loop/loop wrapper elimination" forall loop1 loop2 arr.
440 loopWrapper loop2 (loopArr (loopWrapper loop1 arr)) =
441 loopSndAcc (loopWrapper (sequenceLoops loop1 loop2) arr)
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.
448 "FPS up/up loop fusion" forall f1 f2 acc1 acc2.
449 sequenceLoops (doUpLoop f1 acc1) (doUpLoop f2 acc2) =
450 doUpLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)
452 "FPS map/map loop fusion" forall f1 f2 acc1 acc2.
453 sequenceLoops (doMapLoop f1 acc1) (doMapLoop f2 acc2) =
454 doMapLoop (f1 `fuseMapMapEFL` f2) (acc1 :*: acc2)
456 "FPS filter/filter loop fusion" forall f1 f2 acc1 acc2.
457 sequenceLoops (doFilterLoop f1 acc1) (doFilterLoop f2 acc2) =
458 doFilterLoop (f1 `fuseFilterFilterEFL` f2) (acc1 :*: acc2)
460 "FPS map/filter loop fusion" forall f1 f2 acc1 acc2.
461 sequenceLoops (doMapLoop f1 acc1) (doFilterLoop f2 acc2) =
462 doNoAccLoop (f1 `fuseMapFilterEFL` f2) (acc1 :*: acc2)
464 "FPS filter/map loop fusion" forall f1 f2 acc1 acc2.
465 sequenceLoops (doFilterLoop f1 acc1) (doMapLoop f2 acc2) =
466 doNoAccLoop (f1 `fuseFilterMapEFL` f2) (acc1 :*: acc2)
468 "FPS map/up loop fusion" forall f1 f2 acc1 acc2.
469 sequenceLoops (doMapLoop f1 acc1) (doUpLoop f2 acc2) =
470 doUpLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)
472 "FPS up/map loop fusion" forall f1 f2 acc1 acc2.
473 sequenceLoops (doUpLoop f1 acc1) (doMapLoop f2 acc2) =
474 doUpLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)
476 "FPS filter/up loop fusion" forall f1 f2 acc1 acc2.
477 sequenceLoops (doFilterLoop f1 acc1) (doUpLoop f2 acc2) =
478 doUpLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)
480 "FPS up/filter loop fusion" forall f1 f2 acc1 acc2.
481 sequenceLoops (doUpLoop f1 acc1) (doFilterLoop f2 acc2) =
482 doUpLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)
484 "FPS down/down loop fusion" forall f1 f2 acc1 acc2.
485 sequenceLoops (doDownLoop f1 acc1) (doDownLoop f2 acc2) =
486 doDownLoop (f1 `fuseAccAccEFL` f2) (acc1 :*: acc2)
488 "FPS map/down fusion" forall f1 f2 acc1 acc2.
489 sequenceLoops (doMapLoop f1 acc1) (doDownLoop f2 acc2) =
490 doDownLoop (f1 `fuseMapAccEFL` f2) (acc1 :*: acc2)
492 "FPS down/map loop fusion" forall f1 f2 acc1 acc2.
493 sequenceLoops (doDownLoop f1 acc1) (doMapLoop f2 acc2) =
494 doDownLoop (f1 `fuseAccMapEFL` f2) (acc1 :*: acc2)
496 "FPS filter/down fusion" forall f1 f2 acc1 acc2.
497 sequenceLoops (doFilterLoop f1 acc1) (doDownLoop f2 acc2) =
498 doDownLoop (f1 `fuseFilterAccEFL` f2) (acc1 :*: acc2)
500 "FPS down/filter loop fusion" forall f1 f2 acc1 acc2.
501 sequenceLoops (doDownLoop f1 acc1) (doFilterLoop f2 acc2) =
502 doDownLoop (f1 `fuseAccFilterEFL` f2) (acc1 :*: acc2)
504 "FPS noAcc/noAcc loop fusion" forall f1 f2 acc1 acc2.
505 sequenceLoops (doNoAccLoop f1 acc1) (doNoAccLoop f2 acc2) =
506 doNoAccLoop (f1 `fuseNoAccNoAccEFL` f2) (acc1 :*: acc2)
508 "FPS noAcc/up loop fusion" forall f1 f2 acc1 acc2.
509 sequenceLoops (doNoAccLoop f1 acc1) (doUpLoop f2 acc2) =
510 doUpLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)
512 "FPS up/noAcc loop fusion" forall f1 f2 acc1 acc2.
513 sequenceLoops (doUpLoop f1 acc1) (doNoAccLoop f2 acc2) =
514 doUpLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)
516 "FPS map/noAcc loop fusion" forall f1 f2 acc1 acc2.
517 sequenceLoops (doMapLoop f1 acc1) (doNoAccLoop f2 acc2) =
518 doNoAccLoop (f1 `fuseMapNoAccEFL` f2) (acc1 :*: acc2)
520 "FPS noAcc/map loop fusion" forall f1 f2 acc1 acc2.
521 sequenceLoops (doNoAccLoop f1 acc1) (doMapLoop f2 acc2) =
522 doNoAccLoop (f1 `fuseNoAccMapEFL` f2) (acc1 :*: acc2)
524 "FPS filter/noAcc loop fusion" forall f1 f2 acc1 acc2.
525 sequenceLoops (doFilterLoop f1 acc1) (doNoAccLoop f2 acc2) =
526 doNoAccLoop (f1 `fuseFilterNoAccEFL` f2) (acc1 :*: acc2)
528 "FPS noAcc/filter loop fusion" forall f1 f2 acc1 acc2.
529 sequenceLoops (doNoAccLoop f1 acc1) (doFilterLoop f2 acc2) =
530 doNoAccLoop (f1 `fuseNoAccFilterEFL` f2) (acc1 :*: acc2)
532 "FPS noAcc/down loop fusion" forall f1 f2 acc1 acc2.
533 sequenceLoops (doNoAccLoop f1 acc1) (doDownLoop f2 acc2) =
534 doDownLoop (f1 `fuseNoAccAccEFL` f2) (acc1 :*: acc2)
536 "FPS down/noAcc loop fusion" forall f1 f2 acc1 acc2.
537 sequenceLoops (doDownLoop f1 acc1) (doNoAccLoop f2 acc2) =
538 doDownLoop (f1 `fuseAccNoAccEFL` f2) (acc1 :*: acc2)
546 map = map special case
547 filter = filter special case
548 noAcc = noAcc undirectional loop (unused)
559 each is a special case of the things above
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
566 up/up --> up fuseAccAccEFL
567 down/down --> down fuseAccAccEFL
568 noAcc/noAcc --> noAcc fuseNoAccNoAccEFL
570 noAcc/up --> up fuseNoAccAccEFL
571 up/noAcc --> up fuseAccNoAccEFL
572 noAcc/down --> down fuseNoAccAccEFL
573 down/noAcc --> down fuseAccNoAccEFL
575 and if we do the map, filter special cases then it adds a load more:
577 map/map --> map fuseMapMapEFL
578 filter/filter --> filter fuseFilterFilterEFL
580 map/filter --> noAcc fuseMapFilterEFL
581 filter/map --> noAcc fuseFilterMapEFL
583 map/noAcc --> noAcc fuseMapNoAccEFL
584 noAcc/map --> noAcc fuseNoAccMapEFL
586 map/up --> up fuseMapAccEFL
587 up/map --> up fuseAccMapEFL
589 map/down --> down fuseMapAccEFL
590 down/map --> down fuseAccMapEFL
592 filter/noAcc --> noAcc fuseNoAccFilterEFL
593 noAcc/filter --> noAcc fuseFilterNoAccEFL
595 filter/up --> up fuseFilterAccEFL
596 up/filter --> up fuseAccFilterEFL
598 filter/down --> down fuseFilterAccEFL
599 down/filter --> down fuseAccFilterEFL
602 fuseAccAccEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
603 fuseAccAccEFL f g (acc1 :*: acc2) e1 =
605 acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
606 acc1' :*: JustS e2 ->
608 acc2' :*: res -> (acc1' :*: acc2') :*: res
610 fuseAccNoAccEFL :: AccEFL acc -> NoAccEFL -> AccEFL (PairS acc noAcc)
611 fuseAccNoAccEFL f g (acc :*: noAcc) e1 =
613 acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
614 acc' :*: JustS e2 -> (acc' :*: noAcc) :*: g e2
616 fuseNoAccAccEFL :: NoAccEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
617 fuseNoAccAccEFL f g (noAcc :*: acc) e1 =
619 NothingS -> (noAcc :*: acc) :*: NothingS
622 acc' :*: res -> (noAcc :*: acc') :*: res
624 fuseNoAccNoAccEFL :: NoAccEFL -> NoAccEFL -> NoAccEFL
625 fuseNoAccNoAccEFL f g e1 =
630 fuseMapAccEFL :: MapEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
631 fuseMapAccEFL f g (noAcc :*: acc) e1 =
633 (acc' :*: res) -> (noAcc :*: acc') :*: res
635 fuseAccMapEFL :: AccEFL acc -> MapEFL -> AccEFL (PairS acc noAcc)
636 fuseAccMapEFL f g (acc :*: noAcc) e1 =
638 (acc' :*: NothingS) -> (acc' :*: noAcc) :*: NothingS
639 (acc' :*: JustS e2) -> (acc' :*: noAcc) :*: JustS (g e2)
641 fuseMapMapEFL :: MapEFL -> MapEFL -> MapEFL
642 fuseMapMapEFL f g e1 = g (f e1) -- n.b. perfect fusion
644 fuseMapNoAccEFL :: MapEFL -> NoAccEFL -> NoAccEFL
645 fuseMapNoAccEFL f g e1 = g (f e1)
647 fuseNoAccMapEFL :: NoAccEFL -> MapEFL -> NoAccEFL
648 fuseNoAccMapEFL f g e1 =
651 JustS e2 -> JustS (g e2)
653 fuseAccFilterEFL :: AccEFL acc -> FilterEFL -> AccEFL (PairS acc noAcc)
654 fuseAccFilterEFL f g (acc :*: noAcc) e1 =
656 acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
659 False -> (acc' :*: noAcc) :*: NothingS
660 True -> (acc' :*: noAcc) :*: JustS e2
662 fuseFilterAccEFL :: FilterEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
663 fuseFilterAccEFL f g (noAcc :*: acc) e1 =
665 False -> (noAcc :*: acc) :*: NothingS
668 acc' :*: res -> (noAcc :*: acc') :*: res
670 fuseNoAccFilterEFL :: NoAccEFL -> FilterEFL -> NoAccEFL
671 fuseNoAccFilterEFL f g e1 =
679 fuseFilterNoAccEFL :: FilterEFL -> NoAccEFL -> NoAccEFL
680 fuseFilterNoAccEFL f g e1 =
685 fuseFilterFilterEFL :: FilterEFL -> FilterEFL -> FilterEFL
686 fuseFilterFilterEFL f g e1 = f e1 && g e1
688 fuseMapFilterEFL :: MapEFL -> FilterEFL -> NoAccEFL
689 fuseMapFilterEFL f g e1 =
695 fuseFilterMapEFL :: FilterEFL -> MapEFL -> NoAccEFL
696 fuseFilterMapEFL f g e1 =