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