X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=758d60db04de959e3d30a6a9046265acc04191a6;hb=1ca40c2037a0e973dd73d98cd20313ecdbfeb6fc;hp=4b7e926e423b79f61afb3b62da12eb1c356939cc;hpb=eb2bf7ad9f967861da2e19ff71a80428c7c2df28;p=ghc-hetmet.git

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 4b7e926..758d60d 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -19,23 +19,22 @@ module Rules (
 #include "HsVersions.h"
 
 import CoreSyn		-- All of it
-import CoreSubst	( substExpr, mkSubst )
 import OccurAnal	( occurAnalyseExpr )
 import CoreFVs		( exprFreeVars, exprsFreeVars, bindFreeVars, rulesRhsFreeVars )
 import CoreUnfold	( isCheapUnfolding, unfoldingTemplate )
-import CoreUtils	( tcEqExprX )
+import CoreUtils	( tcEqExprX, exprType )
 import PprCore		( pprRules )
-import Type		( TvSubstEnv )
+import Type		( Type, TvSubstEnv )
 import Coercion         ( coercionKind )
 import TcType		( tcSplitTyConApp_maybe )
 import CoreTidy		( tidyRules )
-import Id		( Id, idUnfolding, isLocalId, isGlobalId, idName,
+import Id		( Id, idUnfolding, isLocalId, isGlobalId, idName, idType,
 			  idSpecialisation, idCoreRules, setIdSpecialisation ) 
 import IdInfo		( SpecInfo( SpecInfo ) )
 import Var		( Var )
 import VarEnv
 import VarSet
-import Name		( Name, NamedThing(..), nameOccName )
+import Name		( Name, NamedThing(..) )
 import NameEnv
 import Unify 		( ruleMatchTyX, MatchEnv(..) )
 import BasicTypes	( Activation, CompilerPhase, isActive )
@@ -196,10 +195,27 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
 %*									*
 %************************************************************************
 
+Note [Extra args in rule matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we find a matching rule, we return (Just (rule, rhs)), 
+but the rule firing has only consumed as many of the input args
+as the ruleArity says.  It's up to the caller to keep track
+of any left-over args.  E.g. if you call
+	lookupRule ... f [e1, e2, e3]
+and it returns Just (r, rhs), where r has ruleArity 2
+then the real rewrite is
+	f e1 e2 e3 ==> rhs e3
+
+You might think it'd be cleaner for lookupRule to deal with the
+leftover arguments, by applying 'rhs' to them, but the main call
+in the Simplifier works better as it is.  Reason: the 'args' passed
+to lookupRule are the result of a lazy substitution
+
 \begin{code}
 lookupRule :: (Activation -> Bool) -> InScopeSet
 	   -> RuleBase	-- Imported rules
 	   -> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr)
+-- See Note [Extra argsin rule matching]
 lookupRule is_active in_scope rule_base fn args
   = matchRules is_active in_scope fn args rules
   where
@@ -482,17 +498,37 @@ match menv subst e1 (Var v2)
 -- potentially inefficient, because of the calls to substExpr,
 -- but I don't think it'll happen much in pracice.
 
+{-  Cases to think about
+	(let x=y+1 in \x. (x,x))
+		--> let x=y+1 in (\x1. (x1,x1))
+	(\x. let x = y+1 in (x,x))
+		--> let x1 = y+1 in (\x. (x1,x1)
+	(let x=y+1 in (x,x), let x=y-1 in (x,x))
+		--> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
+
+Watch out!
+	(let x=y+1 in let z=x+1 in (z,z)
+		--> matches (p,p) but watch out that the use of 
+			x on z's rhs is OK!
+I'm removing the cloning because that makes the above case
+fail, because the inner let looks as if it has locally-bound vars -}
+
 match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2)
-  | not (any locally_bound bind_fvs)
+  | all freshly_bound bndrs,
+    not (any locally_bound bind_fvs)
   = match (menv { me_env = rn_env' }) 
 	  (tv_subst, id_subst, binds `snocOL` bind')
 	  e1 e2'
   where
     rn_env   = me_env menv
     bndrs    = bindersOf  bind
-    rhss     = rhssOfBind bind
     bind_fvs = varSetElems (bindFreeVars bind)
     locally_bound x   = inRnEnvR rn_env x
+    freshly_bound x = not (x `rnInScope` rn_env)
+    bind' = bind
+    e2'   = e2
+    rn_env' = extendRnInScopeList rn_env bndrs
+{-
     (rn_env', bndrs') = mapAccumL rnBndrR rn_env bndrs
     s_prs = [(bndr, Var bndr') | (bndr,bndr') <- zip bndrs bndrs', bndr /= bndr']
     subst = mkSubst (rnInScopeSet rn_env) emptyVarEnv (mkVarEnv s_prs)
@@ -501,6 +537,7 @@ match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2)
     s_bind = case bind of
 		NonRec {} -> NonRec (head bndrs') (head rhss)
 		Rec {}    -> Rec (bndrs' `zip` map (substExpr subst) rhss)
+-}
 
 match menv subst (Lit lit1) (Lit lit2)
   | lit1 == lit2
@@ -594,8 +631,19 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2
 		-> Nothing	-- Occurs check failure
 		-- e.g. match forall a. (\x-> a x) against (\y. y y)
 
-		| otherwise	-- No renaming to do on e2
-		-> Just (tv_subst, extendVarEnv id_subst v1' e2, binds)
+		| otherwise	-- No renaming to do on e2, because no free var
+				-- of e2 is in the rnEnvR of the envt
+		-- However, we must match the *types*; e.g.
+		--   forall (c::Char->Int) (x::Char). 
+		--	f (c x) = "RULE FIRED"
+		-- We must only match on args that have the right type
+		-- It's actually quite difficult to come up with an example that shows
+		-- you need type matching, esp since matching is left-to-right, so type
+		-- args get matched first.  But it's possible (e.g. simplrun008) and
+		-- this is the Right Thing to do
+		-> do	{ tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2)
+						-- c.f. match_ty below
+			; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
 
 	Just e1' | tcEqExprX (nukeRnEnvL rn_env) e1' e2 
 		 -> Just subst
@@ -645,6 +693,11 @@ We only want to replace (f T) with f', not (f Int).
 
 \begin{code}
 ------------------------------------------
+match_ty :: MatchEnv
+      	 -> SubstEnv
+      	 -> Type		-- Template
+      	 -> Type		-- Target
+      	 -> Maybe SubstEnv
 match_ty menv (tv_subst, id_subst, binds) ty1 ty2
   = do	{ tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
 	; return (tv_subst', id_subst, binds) }