Missed beta reductions

[David Feuer]

On Tuesday, March 27, 2018 7:55:02 AM EDT Simon Peyton Jones wrote:
> Yes, it’s possible that he sequence you are seeing is what is happening to you.  But why is that not what you want to see?  What are you trying to achieve?
> 
> Since this function might be applied to many different arguments, it’s probably not a good idea to do anything unconditionally…

I gave rather poor guesses in my last message. I'm trying to get fromListN for Data.Primitive.Array to participate in list fusion. I'm rewriting to a foldr form so it can fuse with build. This is actually working. The trouble is the write-back rule, that's supposed to fire if fusion doesn't happen. That's not working, and I'm quite mystified about why.

-- The basic function
fromListNArray :: Int -> [a] -> Array a
fromListNArray !n l =
  createArray n fromListN_too_short $ \mi ->
    let go i (x:xs)
          | i < n = writeArray mi i x >> go (i+1) xs
          | otherwise = fromListN_too_long
        go i [] = unless (i == n) fromListN_too_short
     in go 0 l
{-# NOINLINE fromListNArray #-}

fromListN_too_short, fromListN_too_long :: a
fromListN_too_short = error "barf"
fromListN_too_long = error "die"
{-# NOINLINE fromListN_too_short #-}
{-# NOINLINE fromListN_too_long #-}

{-# RULES
-- The rule to let it fuse
"fromListNArray/foldr" [~1] forall n xs.
  fromListNArray n xs = createArray n fromListN_too_short $ \mary ->
    foldr (fillArray_go n mary) (fillArray_stop n) xs 0

-- The attempted write-back rule
"fillArrayN/list" [1] forall n mary xs i.
  foldr (fillArray_go n mary) (fillArray_stop n) xs i = fillArrayN n mary xs i
 #-}

fillArrayN :: Int -> MutableArray s a -> [a] -> Int -> ST s ()
fillArrayN !n !mary xs0 !i0 = go i0 xs0
  where
    go i (x:xs)
      | i < n = writeArray mary i x >> go (i+1) xs
      | otherwise = fromListN_too_long
    go i [] = unless (i == n) fromListN_too_short
{-# NOINLINE fillArrayN #-}

fillArray_go :: Int
             -> MutableArray s a
             -> a
             -> (Int -> ST s ())
             -> Int
             -> ST s ()
fillArray_go !n !mary = \x r i ->
  if i < n
    then writeArray mary i x >> r (i + 1)
    else fromListN_too_long
{-# INLINE [0] fillArray_go #-}

fillArray_stop :: Int -> Int -> ST s ()
fillArray_stop !n = \i -> unless (i == n) fromListN_too_short
{-# INLINE [0] fillArray_stop #-}


My test case, which has nothing to fuse with:

bye :: Int -> [Int] -> Array Int
bye n xs = fmap (+1) $ fromListNArray n xs

The fromListNArray/foldr rule fires:

Rule fired
    Rule: fromListNArray/foldr
    Module: (FL)
    Before: fromListNArray TyArg Int ValArg n_a6aF ValArg xs_a6aG
    After:  (\ (@ a_a6XO) (n_a6ba :: Int) (xs_a6bb :: [a_a6XO]) ->
               $ (createArray n_a6ba fromListN_too_short)
                 (\ (@ s_a6XV) (mary_a6bc :: MutableArray s_a6XV a_a6XO) ->
                    foldr
                      (fillArray_go n_a6ba mary_a6bc)
                      (fillArray_stop n_a6ba)
                      xs_a6bb
                      (I# 0#)))
              n_a6aF xs_a6aG
    Cont:   StrictArg $fApplicativeArray_$cfmap
            Stop[BoringCtxt] Array Int

But the fromListArrayN/list rule never does. We go from

bye :: Int -> [Int] -> Array Int
bye
  = \ (n_a6aF :: Int) (xs_a6aG :: [Int]) ->
      case n_a6aF of wild_Xl { I# ds_d70d ->
      case ds_d70d of ds_X70p {
        __DEFAULT ->
          case runRW#
                 (\ (s_i72w :: State# RealWorld) ->
                    case newArray# ds_X70p fromListN_too_short (s_i72w `cast` <Co:97>)
                    of
                    { (# ipv_i72X, ipv1_i72Y #) ->
                    case ((foldr
                             (fillArray_go wild_Xl ((MutableArray ipv1_i72Y) `cast` <Co:97>))
                             (fillArray_stop wild_Xl)
                             xs_a6aG
                             lvl_s7h1)
                          `cast` <Co:3>)
                           (ipv_i72X `cast` <Co:97>)
                    of
                    { (# ipv_i73A, ipv1_i73B #) ->
                    unsafeFreezeArray# (ipv1_i72Y `cast` <Co:197>) ipv_i73A
                    }
                    })
          of
          { (# ipv_i72I, ipv1_i72J #) ->
          $fApplicativeArray_$cfmap lvl_s7h0 (Array ipv1_i72J)
          };
        0# ->
          case emptyArray# (##) of wild_Xd { __DEFAULT ->
          $fApplicativeArray_$cfmap lvl_s7h0 (Array wild_Xd)
          }
      }
      }

to something where everything inlines except errors.