[commit: ghc] master: Fix-up to d4d4bef2 'Improve the desugaring of RULES' (02975c9)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/02975c90c0a587122797930e824a4d45ada26b6a/ghc

>---------------------------------------------------------------

commit 02975c90c0a587122797930e824a4d45ada26b6a
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Aug 1 21:26:51 2014 +0100

    Fix-up to d4d4bef2 'Improve the desugaring of RULES'
    
    I'd forgotten the possiblity that desugaring could generate
    dead dictionary bindings; easily fixed by calling occurAnalyseExpr


>---------------------------------------------------------------

02975c90c0a587122797930e824a4d45ada26b6a
 compiler/deSugar/DsBinds.lhs                        | 10 ++++++++--
 .../tests/simplCore/should_compile/T4398.stderr     | 21 ++++++++++++++++++++-
 testsuite/tests/simplCore/should_compile/all.T      |  2 +-
 .../tests/simplCore/should_compile/simpl016.stderr  |  8 +++++++-
 4 files changed, 36 insertions(+), 5 deletions(-)

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 9297064..172d19b 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -35,6 +35,7 @@ import HsSyn		-- lots of things
 import CoreSyn		-- lots of things
 import Literal          ( Literal(MachStr) )
 import CoreSubst
+import OccurAnal        ( occurAnalyseExpr )
 import MkCore
 import CoreUtils
 import CoreArity ( etaExpand )
@@ -627,7 +628,9 @@ decomposeRuleLhs orig_bndrs orig_lhs
                               , text "Orig lhs:" <+> ppr orig_lhs])
    dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
 			     , ptext (sLit "is not bound in RULE lhs")])
-                      2 (ppr lhs2)
+                      2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
+                              , text "Orig lhs:" <+> ppr orig_lhs
+                              , text "optimised lhs:" <+> ppr lhs2 ])
    pp_bndr bndr
     | isTyVar bndr                      = ptext (sLit "type variable") <+> quotes (ppr bndr)
     | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)
@@ -637,8 +640,11 @@ decomposeRuleLhs orig_bndrs orig_lhs
    drop_dicts e 
        = wrap_lets needed bnds body
      where
-       (bnds, body) = split_lets e
        needed = orig_bndr_set `minusVarSet` exprFreeVars body
+       (bnds, body) = split_lets (occurAnalyseExpr e)
+       	   -- The occurAnalyseExpr drops dead bindings which is
+           -- crucial to ensure that every binding is used later;
+           -- which in turn makes wrap_lets work right
 
    split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
    split_lets e
diff --git a/testsuite/tests/simplCore/should_compile/T4398.stderr b/testsuite/tests/simplCore/should_compile/T4398.stderr
index 63d1ab3..2f1f567 100644
--- a/testsuite/tests/simplCore/should_compile/T4398.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4398.stderr
@@ -1,3 +1,22 @@
 
 T4398.hs:5:11: Warning:
-    Forall'd constraint ‘Ord a’ is not bound in RULE lhs f @ a x y
+    Forall'd constraint ‘Ord a’ is not bound in RULE lhs
+      Orig bndrs: [a, $dOrd, x, y]
+      Orig lhs: let {
+                  $dEq :: Eq a
+                  [LclId, Str=DmdType]
+                  $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
+                f @ a
+                  ((\ ($dOrd :: Ord a) ->
+                      let {
+                        $dEq :: Eq a
+                        [LclId, Str=DmdType]
+                        $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
+                      let {
+                        $dEq :: Eq a
+                        [LclId, Str=DmdType]
+                        $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
+                      x)
+                     $dOrd)
+                  y
+      optimised lhs: f @ a x y
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index c6453d8..f9a5846 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -95,7 +95,7 @@ test('EvalTest',
 
 test('T3831', normal, compile, [''])
 test('T4345', normal, compile, [''])
-test('T4398', normal, compile, [''])
+test('T4398', normal, compile, ['-dsuppress-uniques'])
 
 test('T4903',
      extra_clean(['T4903a.hi', 'T4903a.o']),
diff --git a/testsuite/tests/simplCore/should_compile/simpl016.stderr b/testsuite/tests/simplCore/should_compile/simpl016.stderr
index 2ac4e4f..e08b16d 100644
--- a/testsuite/tests/simplCore/should_compile/simpl016.stderr
+++ b/testsuite/tests/simplCore/should_compile/simpl016.stderr
@@ -1,4 +1,10 @@
 
 simpl016.hs:5:1: Warning:
     Forall'd constraint ‘Num b’ is not bound in RULE lhs
-      delta' @ Int @ b $dEq
+      Orig bndrs: [b, $dNum]
+      Orig lhs: let {
+                  $dEq :: Eq Int
+                  [LclId, Str=DmdType]
+                  $dEq = GHC.Classes.$fEqInt } in
+                delta' @ Int @ b $dEq
+      optimised lhs: delta' @ Int @ b $dEq