From f4ed011ba22d844c62edabfa27f2c8bc6ed4d349 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 1 Mar 2001 15:06:52 +0000 Subject: [PATCH] [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 --- ghc/compiler/typecheck/TcRules.lhs | 25 ++++++++++++++++----- ghc/tests/simplCore/should_run/Makefile | 3 ++- ghc/tests/simplCore/should_run/simplrun001.hs | 2 -- ghc/tests/simplCore/should_run/simplrun001.stderr | 2 -- ghc/tests/simplCore/should_run/simplrun002.hs | 22 ++++++++++++++++++ ghc/tests/simplCore/should_run/simplrun002.stderr | 1 + ghc/tests/simplCore/should_run/simplrun002.stdout | 1 + 7 files changed, 45 insertions(+), 11 deletions(-) create mode 100644 ghc/tests/simplCore/should_run/simplrun002.hs create mode 100644 ghc/tests/simplCore/should_run/simplrun002.stderr create mode 100644 ghc/tests/simplCore/should_run/simplrun002.stdout diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 69d462b..153d37c 100644 --- 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 --- 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 --- 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 --- 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 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 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 index 0000000..0ca9514 --- /dev/null +++ b/ghc/tests/simplCore/should_run/simplrun002.stdout @@ -0,0 +1 @@ +True -- 1.7.10.4