X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FRules.lhs;h=03cc6c1c1869c01b4ac86da6509c14e169609bd2;hb=5b51ce96dae021692d45b9aed5ac7bfe39b237bc;hp=6fc35a515b03d99eb8001d37a9ba4dcb93fa3ec4;hpb=29723ae3cdf941a9647d2cd67e5aa15bab8f4e22;p=ghc-hetmet.git

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 6fc35a5..03cc6c1 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -35,7 +35,7 @@ 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 )
@@ -91,7 +91,7 @@ mkLocalRule name act fn bndrs args rhs
   = Rule { ru_name = name, ru_fn = fn, ru_act = act,
 	   ru_bndrs = bndrs, ru_args = args,
 	   ru_rhs = rhs, ru_rough = roughTopNames args,
-	   ru_orph = Just (nameOccName fn), ru_local = True }
+	   ru_local = True }
 
 --------------
 roughTopNames :: [CoreExpr] -> [Maybe Name]
@@ -348,19 +348,25 @@ matchN in_scope tmpl_vars tmpl_es target_es
 				Just e -> e
 				other  -> unbound tmpl_var'
  
-    unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
+    unbound var = pprPanic "Template variable unbound in rewrite rule" 
+			(ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es)
 \end{code}
 
 Note [Template binders]
 ~~~~~~~~~~~~~~~~~~~~~~~
 Consider the following match:
 	Template:  forall x.  f x 
-	Taret:     f (x+1)
-This should succeed, because the template variable 'x' has nothing to do with
-the 'x' in the target.
+	Target:     f (x+1)
+This should succeed, because the template variable 'x' has 
+nothing to do with the 'x' in the target. 
 
-To achive this, we use rnBndrL to rename the template variables if necessary;
-the renamed ones are the tmpl_vars'
+On reflection, this case probably does just work, but this might not
+	Template:  forall x. f (\x.x) 
+	Target:    f (\y.y)
+Here we want to clone when we find the \x, but to know that x must be in scope
+
+To achive this, we use rnBndrL to rename the template variables if
+necessary; the renamed ones are the tmpl_vars'
 
 
 	---------------------------------------------
@@ -476,8 +482,24 @@ 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'
@@ -487,6 +509,11 @@ match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2)
     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)
@@ -495,6 +522,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
@@ -591,7 +619,7 @@ match_var menv subst@(tv_subst, id_subst, binds) v1 e2
 		| otherwise	-- No renaming to do on e2
 		-> Just (tv_subst, extendVarEnv id_subst v1' e2, binds)
 
-	Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2 
+	Just e1' | tcEqExprX (nukeRnEnvL rn_env) e1' e2 
 		 -> Just subst
 
 		 | otherwise