[project @ 2001-03-01 15:06:52 by simonpj]

Improve rule matching even more

Manuel discovered that given

  {-# RULES "fst over sndSnd" forall v. fst (sndSnd v) = fst v #-}

  sndSnd :: (a, (b, c)) -> (a, c)
  sndSnd (x, (y, z)) = (x, z)

the rule gets a type, which is too specialised, namely

  {-## __R "fst over sndSnd" __forall {@ a1 v :: (a1, ((), ()))}
	   fst @ a1 @ () (sndSnd @ a1 @ () @ () v) = fst @ a1 @ ((), ()) v ;

This was because TcRules wasn't quantifying over enough type variables.

This commit fixes the problem.
The test is in tests/simplCore/should_run/simplrun002

diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs
index 69d462b..153d37c 100644 (file)
--- a/ghc/compiler/typecheck/TcRules.lhs
+++ b/ghc/compiler/typecheck/TcRules.lhs
@@ -22,10 +22,10 @@ import TcExpr               ( tcExpr )
 import TcEnv           ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing )
 import Rules           ( extendRuleBase )
 import Inst            ( LIE, plusLIEs, instToId )
-import Id              ( idName, mkVanillaId )
+import Id              ( idName, idType, mkVanillaId )
 import Module          ( Module )
 import VarSet
-import Type            ( tyVarsOfType, openTypeKind )
+import Type            ( tyVarsOfTypes, openTypeKind )
 import List            ( partition )
 import Outputable
 \end{code}
@@ -106,16 +106,29 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
        --      b) We'd like to make available the dictionaries bound 
        --         on the LHS in the RHS, so quantifying over them is good
        --         See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS
+
+       -- We initially quantify over any tyvars free in *either* the rule
+       -- *or* the bound variables.  The latter is important.  Consider
+       --      ss (x,(y,z)) = (x,z)
+       --      RULE:  forall v. fst (ss v) = fst v
+       -- The type of the rhs of the rule is just a, but v::(a,(b,c))
+       --
+       -- It's still conceivable that there may be type variables mentioned
+       -- in the LHS, but not in the type of the lhs, nor in the binders.
+       -- They'll get zapped to (), but that's over-constraining really.
+       -- Let's see if we get a problem.
+       forall_tvs = varSetElems (tyVarsOfTypes (rule_ty : map idType tpl_ids))
     in
 
        -- RHS can be a bit more lenient.  In particular,
        -- we let constant dictionaries etc float outwards
+       --
+       -- 
     tcSimplifyInferCheck (text "tcRule")
-                        (varSetElems (tyVarsOfType rule_ty))
-                        lhs_dicts rhs_lie      `thenTc` \ (forall_tvs', lie', rhs_binds) ->
+                        forall_tvs
+                        lhs_dicts rhs_lie      `thenTc` \ (forall_tvs1, lie', rhs_binds) ->
 
-    mapTc zonkTcTyVarToTyVar forall_tvs'               `thenTc` \ tvs ->
-    returnTc (lie', HsRule     name tvs
+    returnTc (lie', HsRule     name forall_tvs1
                                (map RuleBndr tpl_ids)  -- yuk
                                (mkHsLet lhs_binds lhs')
                                (mkHsLet rhs_binds rhs')

diff --git a/ghc/tests/simplCore/should_run/Makefile b/ghc/tests/simplCore/should_run/Makefile
index 7ec3806..08c8a8a 100644 (file)
--- a/ghc/tests/simplCore/should_run/Makefile
+++ b/ghc/tests/simplCore/should_run/Makefile
@@ -2,7 +2,8 @@ TOP = ../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/should_run.mk
 
-SRC_HC_OPTS += -dcore-lint
+# NB: -O to test simplifier
+SRC_HC_OPTS += -dcore-lint -O
 
 include $(TOP)/mk/target.mk
 

diff --git a/ghc/tests/simplCore/should_run/simplrun001.hs b/ghc/tests/simplCore/should_run/simplrun001.hs
index f0b02c1..6cbbf76 100644 (file)
--- a/ghc/tests/simplCore/should_run/simplrun001.hs
+++ b/ghc/tests/simplCore/should_run/simplrun001.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS -O #-}
-
 -- !!! Test filter fusion
 
 -- In GHC 4.06, the filterFB rule was back to front, which

diff --git a/ghc/tests/simplCore/should_run/simplrun001.stderr b/ghc/tests/simplCore/should_run/simplrun001.stderr
index 317bd0d..e69de29 100644 (file)
--- a/ghc/tests/simplCore/should_run/simplrun001.stderr
+++ b/ghc/tests/simplCore/should_run/simplrun001.stderr
@@ -1,2 +0,0 @@
-
-Fail: foo

diff --git a/ghc/tests/simplCore/should_run/simplrun002.hs b/ghc/tests/simplCore/should_run/simplrun002.hs
new file mode 100644 (file)
index 0000000..aaa6a4a
--- /dev/null
+++ b/ghc/tests/simplCore/should_run/simplrun002.hs
@@ -0,0 +1,22 @@
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! A rules test
+-- At one time the rule got too specialised a type:
+--
+--  _R "ffoo" forall {@ a1 v :: (a1, ((), ()))} 
+--           fst @ a1 @ () (sndSnd @ a1 @ () @ () v) = fst @ a1 @ ((), ()) v
+
+
+module Main where
+
+import IO
+import PrelIOBase( unsafePerformIO )
+
+sndSnd (a,(b,c)) = (a,c)
+
+trace x y = unsafePerformIO (hPutStr stderr x >> hPutStr stderr "\n" >> return y)
+
+{-# RULES "foo" forall v .  fst (sndSnd v) = trace "Yes" (fst v) #-}
+
+main :: IO ()
+main = print (fst (sndSnd (True, (False,True))))

diff --git a/ghc/tests/simplCore/should_run/simplrun002.stderr b/ghc/tests/simplCore/should_run/simplrun002.stderr
new file mode 100644 (file)
index 0000000..dcd7a5d
--- /dev/null
+++ b/ghc/tests/simplCore/should_run/simplrun002.stderr
@@ -0,0 +1 @@
+Yes

diff --git a/ghc/tests/simplCore/should_run/simplrun002.stdout b/ghc/tests/simplCore/should_run/simplrun002.stdout
new file mode 100644 (file)
index 0000000..0ca9514
--- /dev/null
+++ b/ghc/tests/simplCore/should_run/simplrun002.stdout
@@ -0,0 +1 @@
+True