Add test for #9646

Test Plan: Test that it passes git HEAD and fails with GHC 7.8.

Reviewers: bgamari, hvr, austin, goldfire, thomie

Differential Revision: https://phabricator.haskell.org/D2009

GHC Trac Issues: #9646

10 files changed, 447 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/T9646/Main.hs b/testsuite/tests/simplCore/T9646/Main.hs
new file mode 100644
index 0000000000..352dd03266
--- /dev/null
+++ b/testsuite/tests/simplCore/T9646/Main.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE CPP #-}
+
+#include "MachDeps.h"
+
+#if __GLASGOW_HASKELL__ < 709
+import GHC.Types
+#endif
+
+import StrictPrim
+import Type
+import Natural
+
+
+main :: IO ()
+main = do
+    let (a, b) = (1234, 2345)
+        (na, nb) = (mkSingletonNat a, mkSingletonNat b)
+        nc = timesNatural na nb
+
+    print $ fromNatural na
+    print $ fromNatural nb
+    print $ fromNatural nc
+    checkEtaCount
+
+
+checkEtaCount :: IO ()
+checkEtaCount = do
+    text <- readFile "Natural.dump-simpl"
+    let etaCount = length . filter (== "eta") $ words text
+    if etaCount > 0
+        then error $ "Error : Eta count (" ++ show etaCount ++ ") should 0."
+        else putStrLn "Test passed!"
+
+
+mkSingletonNat :: Word -> Natural
+mkSingletonNat x = runStrictPrim mkNat
+  where
+    mkNat :: StrictPrim s Natural
+    mkNat = do
+        marr <- newWordArray 1
+        writeWordArray marr 0 x
+        narr <- unsafeFreezeWordArray marr
+        return $ Natural 1 narr
+
+
+fromNatural :: Natural -> Word
+fromNatural (Natural _ arr) = indexWordArray arr 0
diff --git a/testsuite/tests/simplCore/T9646/Makefile b/testsuite/tests/simplCore/T9646/Makefile
new file mode 100644
index 0000000000..ce8e69690d
--- /dev/null
+++ b/testsuite/tests/simplCore/T9646/Makefile
@@ -0,0 +1,9 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS += -O2 -dsuppress-uniques -dsuppress-all -ddump-to-file -ddump-ds \
+				-ddump-simpl -ddump-simpl-iterations -ddump-simpl-stats
+
+clean :
+	$(RM) -f *.o *.hi *.dump* cbits/primitive-memops.o T9646
diff --git a/testsuite/tests/simplCore/T9646/Natural.hs b/testsuite/tests/simplCore/T9646/Natural.hs
new file mode 100644
index 0000000000..3d27e376a6
--- /dev/null
+++ b/testsuite/tests/simplCore/T9646/Natural.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
+
+module Natural where
+
+import Prelude hiding (Integer, abs, sum)
+
+import StrictPrim
+import Type
+
+
+{-# NOINLINE timesNatural #-}
+timesNatural :: Natural -> Natural -> Natural
+timesNatural (Natural !n1 !arr1) (Natural !n2 !arr2) =
+    runStrictPrim $ do
+        maxOutLen <- return (1 + n1 + n2)
+        marr <- newWordArray maxOutLen
+        len <- preLoop marr
+        narr <- unsafeFreezeWordArray marr
+        return $! Natural len narr
+  where
+    preLoop marr = do
+        x <- indexWordArrayM arr1 0
+        y <- indexWordArrayM arr2 0
+        let (# cry, prod #) = timesWord2 x y
+        writeWordArray marr 0 prod
+        outerLoop1 1 marr 0 cry
+
+    outerLoop1 !nx !marr !carryhi !carrylo
+        | nx < n2 = do
+            (cryhi, crylo, sum) <- innerLoop1xi nx 0 0 carryhi carrylo
+            writeWordArray marr nx sum
+            outerLoop1 (nx + 1) marr cryhi crylo
+        | otherwise = outerLoop1a nx marr carryhi carrylo
+
+    outerLoop1a !nx !marr !carryhi !carrylo
+        | nx < n1 - 1 = do
+            (cryhi, crylo, sum) <- innerLoop1yi nx 0 0 carryhi carrylo
+            writeWordArray marr nx sum
+            outerLoop1a (nx + 1) marr cryhi crylo
+        | otherwise = outerLoop2 nx marr carryhi carrylo
+
+    innerLoop1xi !xi !yi !carryhi !carrylo !sum
+        | xi >= 0 = do
+            x <- indexWordArrayM arr1 xi
+            y <- indexWordArrayM arr2 yi
+            let (# !cry0, !prod #) = timesWord2 x y
+                (# !cry1, !sum1 #) = plusWord2 prod sum
+                (# !tcryhi, !crylo #) = plusWord2C carrylo cry0 cry1
+                !cryhi = plusWord carryhi tcryhi
+            innerLoop1xi (xi - 1) (yi + 1) cryhi crylo sum1
+        | otherwise = return $! (carryhi, carrylo, sum)
+
+    innerLoop1yi !xi !yi !carryhi !carrylo !sum
+        | yi < n2 = do
+            x <- indexWordArrayM arr1 xi
+            y <- indexWordArrayM arr2 yi
+            let (# !cry0, !prod #) = timesWord2 x y
+                (# !cry1, !sum1 #) = plusWord2 prod sum
+                (# !tcryhi, !crylo #) = plusWord2C carrylo cry0 cry1
+                !cryhi = plusWord carryhi tcryhi
+            innerLoop1yi (xi - 1) (yi + 1) cryhi crylo sum1
+        | otherwise = return $! (carryhi, carrylo, sum)
+
+    outerLoop2 !nx !marr !carryhi !carrylo
+        | nx < n1 + n2 - 1 = do
+            (cryhi, crylo, sum)
+                    <- innerLoop2 (n1 - 1) (nx - n1 + 1) 0 carryhi carrylo
+            writeWordArray marr nx sum
+            outerLoop2 (nx + 1) marr cryhi crylo
+        | carrylo /= 0 = do
+            writeWordArray marr nx carrylo
+            return $! nx + 1
+        | otherwise = return $! nx
+
+    innerLoop2 !xi !yi !carryhi !carrylo !sum
+        | yi < n2 = do
+            x <- indexWordArrayM arr1 xi
+            y <- indexWordArrayM arr2 yi
+            let (# !cry0, !prod #) = timesWord2 x y
+                (# !cry1, !sum1 #) = plusWord2 prod sum
+                (# !tcryhi, !crylo #) = plusWord2C carrylo cry0 cry1
+                !cryhi = plusWord carryhi tcryhi
+            innerLoop2 (xi - 1) (yi + 1) cryhi crylo sum1
+        | otherwise = return $! (carryhi, carrylo, sum)
diff --git a/testsuite/tests/simplCore/T9646/StrictPrim.hs b/testsuite/tests/simplCore/T9646/StrictPrim.hs
new file mode 100644
index 0000000000..5b83f2fcf1
--- /dev/null
+++ b/testsuite/tests/simplCore/T9646/StrictPrim.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE BangPatterns, CPP, MagicHash, NoImplicitPrelude, RankNTypes,
+    TypeFamilies, UnboxedTuples, UnliftedFFITypes #-}
+
+module StrictPrim
+    ( StrictPrim
+    , PrimMonad (..)
+    , runStrictPrim
+    ) where
+
+#if __GLASGOW_HASKELL__ < 709
+import Control.Applicative
+#endif
+
+import GHC.Base
+
+newtype StrictPrim s a
+    = StrictPrim (State# s -> (# State# s, a #))
+
+instance Applicative (StrictPrim s) where
+    {-# INLINE pure #-}
+    pure = return
+
+    {-# INLINE (<*>) #-}
+    (<*>) a b = do f <- a ; v <- b ; return $! (f $! v)
+
+instance Functor (StrictPrim s) where
+    {-# INLINE fmap #-}
+    fmap !f (StrictPrim !m) = StrictPrim $ \ !s ->
+        case m s of
+            (# !new_s,!r #) -> (# new_s, f $! r #)
+
+
+instance Monad (StrictPrim s) where
+    {-# INLINE return #-}
+    return !x = StrictPrim ( \ !s -> (# s, x #))
+
+    {-# INLINE (>>) #-}
+    (!m) >> (!k) = do { _ <- m ;  k }
+
+    {-# INLINE (>>=) #-}
+    (StrictPrim !m) >>= (!k) =
+        StrictPrim ( \ !s ->
+            case m s of
+                (# new_s, r #) -> case k r of
+                    StrictPrim k2 -> k2 new_s
+            )
+
+instance PrimMonad (StrictPrim s) where
+    type PrimState (StrictPrim s) = s
+    {-# INLINE primitive #-}
+    primitive = StrictPrim
+
+
+{-# INLINE runStrictPrim #-}
+runStrictPrim :: (forall s. StrictPrim s a) -> a
+runStrictPrim !st =
+    case st of
+        StrictPrim st_rep ->
+            case st_rep realWorld# of
+                (# _, !r #) -> r
+
+class Monad m => PrimMonad m where
+    type PrimState m
+    primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
+
+#if __GLASGOW_HASKELL__ < 709
+-- Grab this from Prelude (part of Base) because Base depends on this code.
+($!) :: (a -> b) -> a -> b
+f $! x  = let !vx = x in f vx
+#endif
diff --git a/testsuite/tests/simplCore/T9646/T9646.stdout b/testsuite/tests/simplCore/T9646/T9646.stdout
new file mode 100644
index 0000000000..a512fc8dd8
--- /dev/null
+++ b/testsuite/tests/simplCore/T9646/T9646.stdout
@@ -0,0 +1,5 @@
+1234
+2345
+2893730
+Test passed!
+
diff --git a/testsuite/tests/simplCore/T9646/Type.hs b/testsuite/tests/simplCore/T9646/Type.hs
new file mode 100644
index 0000000000..337a7859cc
--- /dev/null
+++ b/testsuite/tests/simplCore/T9646/Type.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}
+
+#include "MachDeps.h"
+
+module Type where
+
+import GHC.Prim
+import GHC.Types
+
+import StrictPrim
+
+data Natural = Natural {-# UNPACK #-} !Int {-# UNPACK #-} !WordArray
+
+data WordArray = WA ByteArray#
+data MutableWordArray m = MWA (MutableByteArray# (PrimState m))
+
+{-# INLINE newWordArray #-}
+newWordArray :: (Monad m, PrimMonad m) => Int -> m (MutableWordArray m)
+newWordArray !len = do
+    let !(I# n#) = len * sizeOfWord
+    primitive (\s# -> case newByteArray# n# s# of
+                        (# s'#, arr# #) -> (# s'#, MWA arr# #))
+
+{-# INLINE unsafeFreezeWordArray #-}
+unsafeFreezeWordArray :: (Monad m, PrimMonad m)
+                        => MutableWordArray m -> m WordArray
+unsafeFreezeWordArray !(MWA arr#) =
+    primitive (\s# -> case unsafeFreezeByteArray# arr# s# of
+                        (# s'#, arr'# #) -> (# s'#, WA arr'# #))
+
+{-# INLINE indexWordArray #-}
+indexWordArray :: WordArray -> Int -> Word
+indexWordArray !(WA arr#) (I# i#) =
+    let w# = indexWordArray# arr# i# in W# w#
+
+{-# INLINE indexWordArrayM #-}
+indexWordArrayM :: Monad m => WordArray -> Int -> m Word
+indexWordArrayM !(WA arr#) (I# i#) =
+    let w# = indexWordArray# arr# i# in
+    case W# w# of x -> return x
+
+
+{-# INLINE writeWordArray #-}
+writeWordArray :: (Monad m, PrimMonad m)
+                        => MutableWordArray m -> Int -> Word -> m ()
+writeWordArray !(MWA arr#) (I# i#) (W# x#) =
+    primitive (\s# ->
+        case writeWordArray# arr# i# x# s# of
+            s'# -> (# s'#, () #))
+
+
+{-# INLINE plusWord #-}
+plusWord :: Word -> Word -> Word
+plusWord (W# a) (W# b) =
+    let !s = plusWord# a b
+    in W# s
+
+{-# INLINE plusWord2 #-}
+plusWord2 :: Word -> Word -> (# Word, Word #)
+plusWord2 (W# a) (W# b) =
+    let (# !c, !s #) = plusWord2# a b
+    in (# W# c, W# s #)
+
+{-# INLINE plusWord2C #-}
+plusWord2C :: Word -> Word -> Word -> (# Word, Word #)
+plusWord2C (W# a) (W# b) (W# c) =
+    let (# !c1, !s1 #) = plusWord2# a b
+        (# !c2, !s2 #) = plusWord2# s1 c
+        !carry = plusWord# c1 c2
+    in (# W# carry, W# s2 #)
+
+{-# INLINE timesWord2 #-}
+timesWord2 :: Word -> Word -> (# Word, Word #)
+timesWord2 (W# a) (W# b) =
+    let (# !ovf, !prod #) = timesWord2# a b
+    in (# W# ovf, W# prod #)
+
+sizeOfWord :: Int
+sizeOfWord = WORD_SIZE_IN_BITS `div` 8
diff --git a/testsuite/tests/simplCore/T9646/cbits/primitive-memops.c b/testsuite/tests/simplCore/T9646/cbits/primitive-memops.c
new file mode 100644
index 0000000000..ac81d67767
--- /dev/null
+++ b/testsuite/tests/simplCore/T9646/cbits/primitive-memops.c
@@ -0,0 +1,25 @@
+#include <string.h>
+#include "primitive-memops.h"
+
+void hsprimitive_memset_Word (HsWord *p, ptrdiff_t off, size_t n, HsWord x)
+{
+  p += off;
+  if (x == 0)
+    memset(p, 0, n * sizeof(HsWord));
+  else if (sizeof(HsWord) == sizeof(int)*2) {
+    int *q = (int *)p;
+    const int *r = (const int *)(void *)&x;
+    while (n>0) {
+      q[0] = r[0];
+      q[1] = r[1];
+      q += 2;
+      --n;
+    }
+  }
+  else {
+    while (n>0) {
+      *p++ = x;
+      --n;
+    }
+  }
+}
diff --git a/testsuite/tests/simplCore/T9646/cbits/primitive-memops.h b/testsuite/tests/simplCore/T9646/cbits/primitive-memops.h
new file mode 100644
index 0000000000..700ef05a8d
--- /dev/null
+++ b/testsuite/tests/simplCore/T9646/cbits/primitive-memops.h
@@ -0,0 +1,10 @@
+#ifndef haskell_primitive_memops_h
+#define haskell_primitive_memops_h
+
+#include <stdlib.h>
+#include <stddef.h>
+#include <HsFFI.h>
+
+void hsprimitive_memset_Word (HsWord *, ptrdiff_t, size_t, HsWord);
+
+#endif
diff --git a/testsuite/tests/simplCore/T9646/readme.txt b/testsuite/tests/simplCore/T9646/readme.txt
new file mode 100644
index 0000000000..954deab06c
--- /dev/null
+++ b/testsuite/tests/simplCore/T9646/readme.txt
@@ -0,0 +1,112 @@
+This is a test for https://ghc.haskell.org/trac/ghc/ticket/9646
+
+The problem addressed in that ticket was that under some circumstances,
+GHC < 7.10.3 was failing to perform eta reduction deterministically.
+
+Compiling this code now (2016/03/16) under ghc-7.8.4 and git HEAD shows that
+ghc-7.8.4 produces more complicated code, with a number of extra lambadas which
+are completely absent in the fast version.
+
+Git HEAD current produces:
+
+    letrec {
+      $wpoly_innerLoop2
+      $wpoly_innerLoop2 =
+        \ @ s ww ww1 ww2 ww3 ww4 w ->
+          case tagToEnum# (<# ww1 dt2) of _ {
+            False -> (# w, (W# ww2, W# ww3, W# ww4) #);
+            True ->
+              case indexWordArray# dt1 ww of w#2 { __DEFAULT ->
+              case indexWordArray# dt3 ww1 of w#3 { __DEFAULT ->
+              case timesWord2# w#2 w#3 of _ { (# ovf1, prod1 #) ->
+              case plusWord2# prod1 ww4 of _ { (# c, s1 #) ->
+              case plusWord2# ww3 ovf1 of _ { (# c1, s2 #) ->
+              case plusWord2# s2 c of _ { (# c2, s3 #) ->
+              $wpoly_innerLoop2
+                (-# ww 1#) (+# ww1 1#) (plusWord# ww2 (plusWord# c1 c2)) s3 s1 w
+              }
+              }
+              }
+              }
+              }
+              }
+          }; } in ....
+
+whereas ghc-7.8, for the same block produces:
+
+    letrec {
+      $wpoly_innerLoop2
+      $wpoly_innerLoop2 =
+        \ @ s ww ww1 ww2 ww3 ww4 ->
+          case tagToEnum# (<# ww1 dt2) of _ {
+            False ->
+              let {
+                sum
+                sum = W# ww4 } in
+              let {
+                carrylo
+                carrylo = W# ww3 } in
+              let {
+                carryhi
+                carryhi = W# ww2 } in
+              let {
+                vx
+                vx = (carryhi, carrylo, sum) } in
+              (\ eta -> (# eta, vx #)) `cast` ...;
+            True ->
+              let {
+                ds3
+                ds3 =
+                  case indexWordArray# dt1 ww of w#2 { __DEFAULT ->
+                  let {
+                    x
+                    x = W# w#2 } in
+                  (\ eta -> (# eta, x #)) `cast` ...
+                  } } in
+              let {
+                lvl
+                lvl =
+                  case indexWordArray# dt3 ww1 of w#2 { __DEFAULT ->
+                  let {
+                    x
+                    x = W# w#2 } in
+                  (\ eta -> (# eta, x #)) `cast` ...
+                  } } in
+              let {
+                a
+                a = -# ww 1 } in
+              let {
+                a1
+                a1 = +# ww1 1 } in
+              (\ eta ->
+                 case (ds3 `cast` ...) eta of _ { (# ipv, ipv3 #) ->
+                 case (lvl `cast` ...) ipv of _ { (# ipv4, ipv5 #) ->
+                 case ipv3 of _ { W# a2 ->
+                 case ipv5 of _ { W# b ->
+                 case timesWord2# a2 b of _ { (# ovf1, prod1 #) ->
+                 case plusWord2# prod1 ww4 of _ { (# c, s1 #) ->
+                 case plusWord2# ww3 ovf1 of _ { (# c1, s2 #) ->
+                 case plusWord2# s2 c of _ { (# c2, s3 #) ->
+                 (($wpoly_innerLoop2 a a1 (plusWord# ww2 (plusWord# c1 c2)) s3 s1)
+                  `cast` ...)
+                   ipv4
+                 }
+                 }
+                 }
+                 }
+                 }
+                 }
+                 }
+                 })
+              `cast` ...
+          }; } in ...
+
+I suspect that in the ghc-7.8.4 case, the lambda:
+
+     (\ eta -> (# eta, x #)) `cast` ...
+
+is preventing the inlining of the indexWordArray# operations.
+
+Much of the code for this test was pulled from the primitive package:
+
+	https://hackage.haskell.org/package/primitive
diff --git a/testsuite/tests/simplCore/T9646/test.T b/testsuite/tests/simplCore/T9646/test.T
new file mode 100644
index 0000000000..2baae525c3
--- /dev/null
+++ b/testsuite/tests/simplCore/T9646/test.T
@@ -0,0 +1,6 @@
+
+test('T9646',
+     [when(fast(), skip), extra_clean(['Main.hi', 'Main.o'])],
+     multimod_compile_and_run,
+     ['Main', ''])
+