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 -- #hide
  12
  13 -- | Functional array fusion for ByteStrings.
  14 --
  15 -- Originally based on code from the Data Parallel Haskell project,
  16 --      <http://www.cse.unsw.edu.au/~chak/project/dph>
  17 --
  18 module Data.ByteString.Fusion (
  19
  20     -- * Fusion utilities
  21     loopU, loopL, fuseEFL,
  22     NoAcc(NoAcc), loopArr, loopAcc, loopSndAcc, unSP,
  23     mapEFL, filterEFL, foldEFL, foldEFL', scanEFL, mapAccumEFL, mapIndexEFL,
  24
  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,
  31
  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,
  37
  38     -- * Strict pairs and sums
  39     PairS(..), MaybeS(..)
  40
  41   ) where
  42
  43 import Data.ByteString.Base
  44
  45 import Foreign.ForeignPtr
  46 import Foreign.Ptr
  47 import Foreign.Storable         (Storable(..))
  48
  49 import Data.Word                (Word8)
  50 import System.IO.Unsafe         (unsafePerformIO)
  51
  52 -- -----------------------------------------------------------------------------
  53 --
  54 -- Useful macros, until we have bang patterns
  55 --
  56
  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
  62
  63 infixl 2 :*:
  64
  65 -- |Strict pair
  66 data PairS a b = !a :*: !b deriving (Eq,Ord,Show)
  67
  68 -- |Strict Maybe
  69 data MaybeS a = NothingS | JustS !a deriving (Eq,Ord,Show)
  70
  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@.
  74 --
  75 data NoAcc = NoAcc
  76
  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
  82
  83 infixr 9 `fuseEFL`
  84
  85 -- |Fuse to flat loop functions
  86 fuseEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
  87 fuseEFL f g (acc1 :*: acc2) e1 =
  88     case f acc1 e1 of
  89         acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
  90         acc1' :*: JustS e2 ->
  91             case g acc2 e2 of
  92                 acc2' :*: res -> (acc1' :*: acc2') :*: res
  93 #if defined(__GLASGOW_HASKELL__)
  94 {-# INLINE [1] fuseEFL #-}
  95 #endif
  96
  97 -- | Special forms of loop arguments
  98 --
  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.
 104 --
 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.
 108 --
 109
 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))
 114 #else
 115 mapEFL :: (Word8 -> Word8) -> NoAccEFL
 116 mapEFL f = \e -> JustS (f e)
 117 #endif
 118 #if defined(__GLASGOW_HASKELL__)
 119 {-# INLINE [1] mapEFL #-}
 120 #endif
 121
 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)
 126 #else
 127 filterEFL :: (Word8 -> Bool) -> NoAccEFL
 128 filterEFL p = \e -> if p e then JustS e else NothingS
 129 #endif
 130
 131 #if defined(__GLASGOW_HASKELL__)
 132 {-# INLINE [1] filterEFL #-}
 133 #endif
 134
 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 #-}
 140 #endif
 141
 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' #-}
 147 #endif
 148
 149 -- | Element function expressing a prefix reduction only
 150 --
 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 #-}
 155 #endif
 156
 157 -- | Element function implementing a map and fold
 158 --
 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 #-}
 163 #endif
 164
 165 -- | Element function implementing a map with index
 166 --
 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 #-}
 171 #endif
 172
 173 -- | Projection functions that are fusion friendly (as in, we determine when
 174 -- they are inlined)
 175 loopArr :: (PairS acc arr) -> arr
 176 loopArr (_ :*: arr) = arr
 177 #if defined(__GLASGOW_HASKELL__)
 178 {-# INLINE [1] loopArr #-}
 179 #endif
 180
 181 loopAcc :: (PairS acc arr) -> acc
 182 loopAcc (acc :*: _) = acc
 183 #if defined(__GLASGOW_HASKELL__)
 184 {-# INLINE [1] loopAcc #-}
 185 #endif
 186
 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 #-}
 191 #endif
 192
 193 unSP :: (PairS acc arr) -> (acc, arr)
 194 unSP (acc :*: arr) = (acc, arr)
 195 #if defined(__GLASGOW_HASKELL__)
 196 {-# INLINE [1] unSP #-}
 197 #endif
 198
 199 ------------------------------------------------------------------------
 200 --
 201 -- Loop combinator and fusion rules for flat arrays
 202 -- |Iteration over over ByteStrings
 203
 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)
 209
 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
 213       return (0, i', acc')
 214     return (acc :*: ps)
 215
 216   where
 217     go p ma = trans 0 0
 218         where
 219             STRICT3(trans)
 220             trans a_off ma_off acc
 221                 | a_off >= i = return (acc :*: ma_off)
 222                 | otherwise  = do
 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
 228                                        return $ ma_off + 1
 229                     trans (a_off+1) ma_off' acc'
 230
 231 #if defined(__GLASGOW_HASKELL__)
 232 {-# INLINE [1] loopU #-}
 233 #endif
 234
 235 {-# RULES
 236
 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)
 240
 241   #-}
 242
 243 --
 244 -- Functional list/array fusion for lazy ByteStrings.
 245 --
 246 loopL :: AccEFL acc          -- ^ mapping & folding, once per elem
 247       -> acc                 -- ^ initial acc value
 248       -> [ByteString]        -- ^ input ByteString
 249       -> PairS acc [ByteString]
 250 loopL f = loop
 251   where loop s []     = (s :*: [])
 252         loop s (x:xs)
 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
 257
 258 #if defined(__GLASGOW_HASKELL__)
 259 {-# INLINE [1] loopL #-}
 260 #endif
 261
 262 {-# RULES
 263
 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)
 267
 268   #-}
 269
 270
 271 {-
 272
 273 Alternate experimental formulation of loopU which partitions it into
 274 an allocating wrapper and an imperitive array-mutating loop.
 275
 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.
 279
 280 Note that this stuff needs ghc-6.5 from May 26 or later for the RULES to
 281 really work reliably.
 282
 283 -}
 284
 285 loopUp :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
 286 loopUp f a arr = loopWrapper (doUpLoop f a) arr
 287 {-# INLINE loopUp #-}
 288
 289 loopDown :: AccEFL acc -> acc -> ByteString -> PairS acc ByteString
 290 loopDown f a arr = loopWrapper (doDownLoop f a) arr
 291 {-# INLINE loopDown #-}
 292
 293 loopNoAcc :: NoAccEFL -> ByteString -> PairS NoAcc ByteString
 294 loopNoAcc f arr = loopWrapper (doNoAccLoop f NoAcc) arr
 295 {-# INLINE loopNoAcc #-}
 296
 297 loopMap :: MapEFL -> ByteString -> PairS NoAcc ByteString
 298 loopMap f arr = loopWrapper (doMapLoop f NoAcc) arr
 299 {-# INLINE loopMap #-}
 300
 301 loopFilter :: FilterEFL -> ByteString -> PairS NoAcc ByteString
 302 loopFilter f arr = loopWrapper (doFilterLoop f NoAcc) arr
 303 {-# INLINE loopFilter #-}
 304
 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.
 310 --
 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
 316
 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)
 324     return (acc :*: ps)
 325
 326 doUpLoop :: AccEFL acc -> acc -> ImperativeLoop acc
 327 doUpLoop f acc0 src dest len = loop 0 0 acc0
 328   where STRICT3(loop)
 329         loop src_off dest_off acc
 330             | src_off >= len = return (acc :*: 0 :*: dest_off)
 331             | otherwise      = do
 332                 x <- peekByteOff src src_off
 333                 case f acc x of
 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'
 337
 338 doDownLoop :: AccEFL acc -> acc -> ImperativeLoop acc
 339 doDownLoop f acc0 src dest len = loop (len-1) (len-1) acc0
 340   where STRICT3(loop)
 341         loop src_off dest_off acc
 342             | src_off < 0 = return (acc :*: dest_off + 1 :*: len - (dest_off + 1))
 343             | otherwise   = do
 344                 x <- peekByteOff src src_off
 345                 case f acc x of
 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'
 349
 350 doNoAccLoop :: NoAccEFL -> noAcc -> ImperativeLoop noAcc
 351 doNoAccLoop f noAcc src dest len = loop 0 0
 352   where STRICT2(loop)
 353         loop src_off dest_off
 354             | src_off >= len = return (noAcc :*: 0 :*: dest_off)
 355             | otherwise      = do
 356                 x <- peekByteOff src src_off
 357                 case f x of
 358                   NothingS -> loop (src_off+1) dest_off
 359                   JustS x' -> pokeByteOff dest dest_off x'
 360                            >> loop (src_off+1) (dest_off+1)
 361
 362 doMapLoop :: MapEFL -> noAcc -> ImperativeLoop noAcc
 363 doMapLoop f noAcc src dest len = loop 0
 364   where STRICT1(loop)
 365         loop n
 366             | n >= len = return (noAcc :*: 0 :*: len)
 367             | otherwise      = do
 368                 x <- peekByteOff src n
 369                 pokeByteOff dest n (f x)
 370                 loop (n+1) -- offset always the same, only pass 1 arg
 371
 372 doFilterLoop :: FilterEFL -> noAcc -> ImperativeLoop noAcc
 373 doFilterLoop f noAcc src dest len = loop 0 0
 374   where STRICT2(loop)
 375         loop src_off dest_off
 376             | src_off >= len = return (noAcc :*: 0 :*: dest_off)
 377             | otherwise      = do
 378                 x <- peekByteOff src src_off
 379                 if f x
 380                   then pokeByteOff dest dest_off x
 381                     >> loop (src_off+1) (dest_off+1)
 382                   else loop (src_off+1) dest_off
 383
 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)
 398
 399   -- TODO: prove that this is associative! (I think it is)
 400   -- since we can't be sure how the RULES will combine loops.
 401
 402 #if defined(__GLASGOW_HASKELL__)
 403
 404 {-# INLINE [1] doUpLoop             #-}
 405 {-# INLINE [1] doDownLoop           #-}
 406 {-# INLINE [1] doNoAccLoop          #-}
 407 {-# INLINE [1] doMapLoop            #-}
 408 {-# INLINE [1] doFilterLoop         #-}
 409
 410 {-# INLINE [1] loopWrapper          #-}
 411 {-# INLINE [1] sequenceLoops        #-}
 412
 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     #-}
 429
 430 #endif
 431
 432 {-# RULES
 433
 434 "FPS loopArr/loopSndAcc" forall x.
 435   loopArr (loopSndAcc x) = loopArr x
 436
 437 "FPS seq/NoAcc" forall (u::NoAcc) e.
 438   u `seq` e = e
 439
 440 "FPS loop/loop wrapper elimination" forall loop1 loop2 arr.
 441   loopWrapper loop2 (loopArr (loopWrapper loop1 arr)) =
 442     loopSndAcc (loopWrapper (sequenceLoops loop1 loop2) arr)
 443
 444 --
 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.
 447 --
 448
 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)
 452
 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)
 456
 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)
 460
 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)
 464
 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)
 468
 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)
 472
 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)
 476
 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)
 480
 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)
 484
 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)
 488
 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)
 492
 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)
 496
 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)
 500
 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)
 504
 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)
 508
 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)
 512
 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)
 516
 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)
 520
 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)
 524
 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)
 528
 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)
 532
 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)
 536
 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)
 540
 541   #-}
 542
 543 {-
 544
 545 up      = up loop
 546 down    = down loop
 547 map     = map special case
 548 filter  = filter special case
 549 noAcc   = noAcc undirectional loop (unused)
 550
 551 heirarchy:
 552   up     down
 553    ^     ^
 554     \   /
 555     noAcc
 556      ^ ^
 557     /   \
 558  map     filter
 559
 560 each is a special case of the things above
 561
 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
 565
 566 so all the cases:
 567 up/up         --> up     fuseAccAccEFL
 568 down/down     --> down   fuseAccAccEFL
 569 noAcc/noAcc   --> noAcc  fuseNoAccNoAccEFL
 570
 571 noAcc/up      --> up     fuseNoAccAccEFL
 572 up/noAcc      --> up     fuseAccNoAccEFL
 573 noAcc/down    --> down   fuseNoAccAccEFL
 574 down/noAcc    --> down   fuseAccNoAccEFL
 575
 576 and if we do the map, filter special cases then it adds a load more:
 577
 578 map/map       --> map    fuseMapMapEFL
 579 filter/filter --> filter fuseFilterFilterEFL
 580
 581 map/filter    --> noAcc  fuseMapFilterEFL
 582 filter/map    --> noAcc  fuseFilterMapEFL
 583
 584 map/noAcc     --> noAcc  fuseMapNoAccEFL
 585 noAcc/map     --> noAcc  fuseNoAccMapEFL
 586
 587 map/up        --> up     fuseMapAccEFL
 588 up/map        --> up     fuseAccMapEFL
 589
 590 map/down      --> down   fuseMapAccEFL
 591 down/map      --> down   fuseAccMapEFL
 592
 593 filter/noAcc  --> noAcc  fuseNoAccFilterEFL
 594 noAcc/filter  --> noAcc  fuseFilterNoAccEFL
 595
 596 filter/up     --> up     fuseFilterAccEFL
 597 up/filter     --> up     fuseAccFilterEFL
 598
 599 filter/down   --> down   fuseFilterAccEFL
 600 down/filter   --> down   fuseAccFilterEFL
 601 -}
 602
 603 fuseAccAccEFL :: AccEFL acc1 -> AccEFL acc2 -> AccEFL (PairS acc1 acc2)
 604 fuseAccAccEFL f g (acc1 :*: acc2) e1 =
 605     case f acc1 e1 of
 606         acc1' :*: NothingS -> (acc1' :*: acc2) :*: NothingS
 607         acc1' :*: JustS e2 ->
 608             case g acc2 e2 of
 609                 acc2' :*: res -> (acc1' :*: acc2') :*: res
 610
 611 fuseAccNoAccEFL :: AccEFL acc -> NoAccEFL -> AccEFL (PairS acc noAcc)
 612 fuseAccNoAccEFL f g (acc :*: noAcc) e1 =
 613     case f acc e1 of
 614         acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
 615         acc' :*: JustS e2 -> (acc' :*: noAcc) :*: g e2
 616
 617 fuseNoAccAccEFL :: NoAccEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
 618 fuseNoAccAccEFL f g (noAcc :*: acc) e1 =
 619     case f e1 of
 620         NothingS -> (noAcc :*: acc) :*: NothingS
 621         JustS e2 ->
 622             case g acc e2 of
 623                 acc' :*: res -> (noAcc :*: acc') :*: res
 624
 625 fuseNoAccNoAccEFL :: NoAccEFL -> NoAccEFL -> NoAccEFL
 626 fuseNoAccNoAccEFL f g e1 =
 627     case f e1 of
 628         NothingS -> NothingS
 629         JustS e2 -> g e2
 630
 631 fuseMapAccEFL :: MapEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
 632 fuseMapAccEFL f g (noAcc :*: acc) e1 =
 633     case g acc (f e1) of
 634         (acc' :*: res) -> (noAcc :*: acc') :*: res
 635
 636 fuseAccMapEFL :: AccEFL acc -> MapEFL -> AccEFL (PairS acc noAcc)
 637 fuseAccMapEFL f g (acc :*: noAcc) e1 =
 638     case f acc e1 of
 639         (acc' :*: NothingS) -> (acc' :*: noAcc) :*: NothingS
 640         (acc' :*: JustS e2) -> (acc' :*: noAcc) :*: JustS (g e2)
 641
 642 fuseMapMapEFL :: MapEFL -> MapEFL -> MapEFL
 643 fuseMapMapEFL   f g e1 = g (f e1)     -- n.b. perfect fusion
 644
 645 fuseMapNoAccEFL :: MapEFL -> NoAccEFL -> NoAccEFL
 646 fuseMapNoAccEFL f g e1 = g (f e1)
 647
 648 fuseNoAccMapEFL :: NoAccEFL -> MapEFL -> NoAccEFL
 649 fuseNoAccMapEFL f g e1 =
 650     case f e1 of
 651         NothingS -> NothingS
 652         JustS e2 -> JustS (g e2)
 653
 654 fuseAccFilterEFL :: AccEFL acc -> FilterEFL -> AccEFL (PairS acc noAcc)
 655 fuseAccFilterEFL f g (acc :*: noAcc) e1 =
 656     case f acc e1 of
 657         acc' :*: NothingS -> (acc' :*: noAcc) :*: NothingS
 658         acc' :*: JustS e2 ->
 659             case g e2 of
 660                 False -> (acc' :*: noAcc) :*: NothingS
 661                 True  -> (acc' :*: noAcc) :*: JustS e2
 662
 663 fuseFilterAccEFL :: FilterEFL -> AccEFL acc -> AccEFL (PairS noAcc acc)
 664 fuseFilterAccEFL f g (noAcc :*: acc) e1 =
 665     case f e1 of
 666         False -> (noAcc :*: acc) :*: NothingS
 667         True  ->
 668             case g acc e1 of
 669                 acc' :*: res -> (noAcc :*: acc') :*: res
 670
 671 fuseNoAccFilterEFL :: NoAccEFL -> FilterEFL -> NoAccEFL
 672 fuseNoAccFilterEFL f g e1 =
 673     case f e1 of
 674         NothingS -> NothingS
 675         JustS e2 ->
 676             case g e2 of
 677                 False -> NothingS
 678                 True  -> JustS e2
 679
 680 fuseFilterNoAccEFL :: FilterEFL -> NoAccEFL -> NoAccEFL
 681 fuseFilterNoAccEFL f g e1 =
 682     case f e1 of
 683         False -> NothingS
 684         True  -> g e1
 685
 686 fuseFilterFilterEFL :: FilterEFL -> FilterEFL -> FilterEFL
 687 fuseFilterFilterEFL f g e1 = f e1 && g e1
 688
 689 fuseMapFilterEFL :: MapEFL -> FilterEFL -> NoAccEFL
 690 fuseMapFilterEFL f g e1 =
 691     case f e1 of
 692         e2 -> case g e2 of
 693             False -> NothingS
 694             True  -> JustS e2
 695
 696 fuseFilterMapEFL :: FilterEFL -> MapEFL -> NoAccEFL
 697 fuseFilterMapEFL f g e1 =
 698     case f e1 of
 699         False -> NothingS
 700         True  -> JustS (g e1)
 701