Refactor to combine two eqExpr functions

I'd forgotten that Rules.lhs already has an eqExpr function.  This
patch combines Rules.eqExpr with the (recent) CoreUtils.eqExpr.

I also did a little refactoring by defining CoreSyn.expandUnfolding_maybe
(see Note [Expanding variables] in Rules.lhs), and using it in
     a) CoreUnfold.exprIsConApp_maybe
     b) Rule matching

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 5c7cef9..04d3906 100644 (file)
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -43,7 +43,7 @@ module CoreSyn (
         unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
        
        -- ** Predicates and deconstruction on 'Unfolding'
         unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
        
        -- ** Predicates and deconstruction on 'Unfolding'

-       unfoldingTemplate, setUnfoldingTemplate,
+       unfoldingTemplate, setUnfoldingTemplate, expandUnfolding_maybe,

        maybeUnfoldingTemplate, otherCons, unfoldingArity,
        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
        maybeUnfoldingTemplate, otherCons, unfoldingArity,
        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,

@@ -583,6 +583,13 @@ isExpandableUnfolding :: Unfolding -> Bool
 isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
 isExpandableUnfolding _                                              = False
 
 isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
 isExpandableUnfolding _                                              = False
 

+expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
+-- Expand an expandable unfolding; this is used in rule matching 
+--   See Note [Expanding variables] in Rules.lhs
+-- The key point here is that CONLIKE things can be expanded
+expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
+expandUnfolding_maybe _                                                       = Nothing
+

 isInlineRule :: Unfolding -> Bool
 isInlineRule (CoreUnfolding { uf_src = src }) = isInlineRuleSource src
 isInlineRule _                               = False
 isInlineRule :: Unfolding -> Bool
 isInlineRule (CoreUnfolding { uf_src = src }) = isInlineRuleSource src
 isInlineRule _                               = False

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 798d94b..f8043d4 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -1169,14 +1169,12 @@ exprIsConApp_maybe id_unf expr
 
        -- Look through unfoldings, but only cheap ones, because
        -- we are effectively duplicating the unfolding
 
        -- Look through unfoldings, but only cheap ones, because
        -- we are effectively duplicating the unfolding

-       | CoreUnfolding { uf_expandable = expand_me, uf_tmpl = rhs } <- unfolding
-       , expand_me = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
-                      analyse rhs args
+       | Just rhs <- expandUnfolding_maybe unfolding
+       = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
+          analyse rhs args

         where
          is_saturated = count isValArg args == idArity fun
         where
          is_saturated = count isValArg args == idArity fun

-          unfolding = id_unf fun    -- Does not look through loop breakers
-                   -- ToDo: we *may* look through variables that are NOINLINE
-                   --       in this phase, and that is really not right
+         unfolding = id_unf fun

 
     analyse _ _ = Nothing
 
 
     analyse _ _ = Nothing
 

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index ed8d6f2..58d662e 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -36,7 +36,7 @@ module CoreUtils (
        hashExpr,
 
        -- * Equality
        hashExpr,
 
        -- * Equality

-       cheapEqExpr, eqExpr,
+       cheapEqExpr, eqExpr, eqExprX,

 
        -- * Manipulating data constructors and types
        applyTypeToArgs, applyTypeToArg,
 
        -- * Manipulating data constructors and types
        applyTypeToArgs, applyTypeToArg,

@@ -966,36 +966,62 @@ exprIsBig _            = True
 eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
 -- Compares for equality, modulo alpha
 eqExpr in_scope e1 e2
 eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
 -- Compares for equality, modulo alpha
 eqExpr in_scope e1 e2

-  = go (mkRnEnv2 in_scope) e1 e2
+  = eqExprX id_unf (mkRnEnv2 in_scope) e1 e2

   where
   where

-    go _   (Lit lit1)  (Lit lit2)   = lit1 == lit2
-    go env (Type t1)   (Type t2)    = coreEqType2 env t1 t2
-    go env (Var v1)    (Var v2)     = rnOccL env v1 == rnOccR env v2
-    go env (Cast e1 t1) (Cast e2 t2) = go env e1 e2 && coreEqCoercion2 env t1 t2
-    go env (App f1 a1)  (App f2 a2)  = go env f1 f2 && go env a1 a2
+    id_unf _ = noUnfolding     -- Don't expand
+\end{code}
+    
+\begin{code}
+eqExprX :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool
+-- ^ Compares expressions for equality, modulo alpha.
+-- Does /not/ look through newtypes or predicate types
+-- Used in rule matching, and also CSE
+
+eqExprX id_unfolding_fun env e1 e2
+  = go env e1 e2
+  where
+    go env (Var v1) (Var v2)
+      | rnOccL env v1 == rnOccR env v2
+      = True
+
+    -- The next two rules expand non-local variables
+    -- C.f. Note [Expanding variables] in Rules.lhs
+    -- and  Note [Do not expand locally-bound variables] in Rules.lhs
+    go env (Var v1) e2
+      | not (locallyBoundL env v1)
+      , Just e1' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v1))
+      = go (nukeRnEnvL env) e1' e2
+
+    go env e1 (Var v2)
+      | not (locallyBoundR env v2)
+      , Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2))
+      = go (nukeRnEnvR env) e1 e2'
+
+    go _   (Lit lit1)    (Lit lit2)    = lit1 == lit2
+    go env (Type t1)     (Type t2)     = tcEqTypeX env t1 t2
+    go env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && go env e1 e2
+    go env (App f1 a1)   (App f2 a2)   = go env f1 f2 && go env a1 a2
+    go env (Note n1 e1)  (Note n2 e2)  = go_note n1 n2 && go env e1 e2

 
     go env (Lam b1 e1)  (Lam b2 e2)  
 
     go env (Lam b1 e1)  (Lam b2 e2)  

-      =  coreEqType2 env (varType b1) (varType b2)     -- Will return False for Id/TyVar combination
+      =  tcEqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination

       && go (rnBndr2 env b1 b2) e1 e2
 
       && go (rnBndr2 env b1 b2) e1 e2
 

+    go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) 
+      =  go env r1 r2  -- No need to check binder types, since RHSs match
+      && go (rnBndr2 env v1 v2) e1 e2
+
+    go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) 
+      = all2 (go env') rs1 rs2 && go env' e1 e2
+      where
+        (bs1,rs1) = unzip ps1     
+        (bs2,rs2) = unzip ps2
+        env' = rnBndrs2 env bs1 bs2
+

     go env (Case e1 b1 _ a1) (Case e2 b2 _ a2)
       =  go env e1 e2
     go env (Case e1 b1 _ a1) (Case e2 b2 _ a2)
       =  go env e1 e2

-      && coreEqType2 env (idType b1) (idType b2)
+      && tcEqTypeX env (idType b1) (idType b2)

       && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2
       && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2

-   
-    go env (Let (NonRec b1 r1) e1) (Let (NonRec b2 r2) e2)
-      =  go env r1 r2  -- No need to check binder types, since RHSs match
-      && go (rnBndr2 env b1 b2) e1 e2  
-
-    go env (Let (Rec p1) e1) (Let (Rec p2) e2)
-      | equalLength p1 p2
-      =  all2 (go env') rs1 rs2 && go env' e1 e2
-      where
-         (bs1,rs1) = unzip p1
-         (bs2,rs2) = unzip p2
-         env' = rnBndrs2 env bs1 bs2
-
-    go env (Note n1 e1) (Note n2 e2) = go_note n1 n2 && go env e1 e2

 
     go _ _ _ = False
 
 
     go _ _ _ = False
 

@@ -1004,11 +1030,19 @@ eqExpr in_scope e1 e2
       = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2
 
     -----------
       = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2
 
     -----------

-    go_note (SCC cc1)     (SCC cc2)     = cc1==cc2
-    go_note (CoreNote s1) (CoreNote s2) = s1==s2
-    go_note _ _ = False
+    go_note (SCC cc1)     (SCC cc2)      = cc1 == cc2
+    go_note (CoreNote s1) (CoreNote s2)  = s1 == s2
+    go_note _             _              = False

 \end{code}
 \end{code}

-    
+
+Auxiliary functions
+
+\begin{code}
+locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool
+locallyBoundL rn_env v = inRnEnvL rn_env v
+locallyBoundR rn_env v = inRnEnvR rn_env v
+\end{code}
+

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 5bd22a1..e1dc927 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -32,9 +32,9 @@ module Rules (
 import CoreSyn         -- All of it
 import OccurAnal       ( occurAnalyseExpr )
 import CoreFVs         ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
 import CoreSyn         -- All of it
 import OccurAnal       ( occurAnalyseExpr )
 import CoreFVs         ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )

-import CoreUtils       ( exprType )
+import CoreUtils       ( exprType, eqExprX )

 import PprCore         ( pprRules )
 import PprCore         ( pprRules )

-import Type            ( Type, TvSubstEnv, tcEqTypeX )
+import Type            ( Type, TvSubstEnv )

 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )
 import Id
 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )
 import Id

@@ -587,8 +587,8 @@ match idu menv subst e1 (Note _ e2) = match idu menv subst e1 e2
       -- See Note [Notes in RULE matching]
 
 match id_unfolding_fun menv subst e1 (Var v2)      -- Note [Expanding variables]
       -- See Note [Notes in RULE matching]
 
 match id_unfolding_fun menv subst e1 (Var v2)      -- Note [Expanding variables]

-  | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables]
-  , Just e2' <- expandUnfolding (id_unfolding_fun v2')
+  | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]
+  , Just e2' <- expandUnfolding_maybe (id_unfolding_fun v2')

   = match id_unfolding_fun (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2'
   where
     v2'    = lookupRnInScope rn_env v2
   = match id_unfolding_fun (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2'
   where
     v2'    = lookupRnInScope rn_env v2

@@ -596,11 +596,11 @@ match id_unfolding_fun menv subst e1 (Var v2)      -- Note [Expanding variables]
        -- Notice that we look up v2 in the in-scope set
        -- See Note [Lookup in-scope]
        -- No need to apply any renaming first (hence no rnOccR)
        -- Notice that we look up v2 in the in-scope set
        -- See Note [Lookup in-scope]
        -- No need to apply any renaming first (hence no rnOccR)

-       -- becuase of the not-locallyBoundR
+       -- because of the not-inRnEnvR

 
 match idu menv (tv_subst, id_subst, binds) e1 (Let bind e2)
   | all freshly_bound bndrs    -- See Note [Matching lets]
 
 match idu menv (tv_subst, id_subst, binds) e1 (Let bind e2)
   | all freshly_bound bndrs    -- See Note [Matching lets]

-  , not (any (locallyBoundR rn_env) bind_fvs)
+  , not (any (inRnEnvR rn_env) bind_fvs)

   = match idu (menv { me_env = rn_env' }) 
          (tv_subst, id_subst, binds `snocOL` bind')
          e1 e2'
   = match idu (menv { me_env = rn_env' }) 
          (tv_subst, id_subst, binds `snocOL` bind')
          e1 e2'

@@ -693,7 +693,7 @@ match_var idu menv subst@(tv_subst, id_subst, binds) v1 e2
                                                -- c.f. match_ty below
                        ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
 
                                                -- c.f. match_ty below
                        ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
 

-       Just e1' | eqExpr idu (nukeRnEnvL rn_env) e1' e2 
+       Just e1' | eqExprX idu (nukeRnEnvL rn_env) e1' e2 

                 -> Just subst
 
                 | otherwise
                 -> Just subst
 
                 | otherwise

@@ -867,77 +867,6 @@ at all.
 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
 is so important.
 
 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
 is so important.
 

-\begin{code}
-eqExpr :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool
--- ^ A kind of shallow equality used in rule matching, so does 
--- /not/ look through newtypes or predicate types
-
-eqExpr _ env (Var v1) (Var v2)
-  | rnOccL env v1 == rnOccR env v2
-  = True
-
--- The next two rules expand non-local variables
--- C.f. Note [Expanding variables]
--- and  Note [Do not expand locally-bound variables]
-eqExpr id_unfolding_fun env (Var v1) e2
-  | not (locallyBoundL env v1)
-  , Just e1' <- expandUnfolding (id_unfolding_fun (lookupRnInScope env v1))
-  = eqExpr id_unfolding_fun (nukeRnEnvL env) e1' e2
-
-eqExpr id_unfolding_fun env e1 (Var v2)
-  | not (locallyBoundR env v2)
-  , Just e2' <- expandUnfolding (id_unfolding_fun (lookupRnInScope env v2))
-  = eqExpr id_unfolding_fun (nukeRnEnvR env) e1 e2'
-
-eqExpr _   _   (Lit lit1)    (Lit lit2)    = lit1 == lit2
-eqExpr idu env (App f1 a1)   (App f2 a2)   = eqExpr idu env f1 f2 && eqExpr idu env a1 a2
-eqExpr idu env (Lam v1 e1)   (Lam v2 e2)   = eqExpr idu (rnBndr2 env v1 v2) e1 e2
-eqExpr idu env (Note n1 e1)  (Note n2 e2)  = eq_note env n1 n2 && eqExpr idu env e1 e2
-eqExpr idu env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && eqExpr idu env e1 e2
-eqExpr _   env (Type t1)     (Type t2)     = tcEqTypeX env t1 t2
-
-eqExpr idu env (Let (NonRec v1 r1) e1)
-              (Let (NonRec v2 r2) e2) =  eqExpr idu env r1 r2 
-                                      && eqExpr idu (rnBndr2 env v1 v2) e1 e2
-eqExpr idu env (Let (Rec ps1) e1)
-              (Let (Rec ps2) e2)      =  equalLength ps1 ps2
-                                      && and (zipWith eq_rhs ps1 ps2)
-                                      && eqExpr idu env' e1 e2
-                                      where
-                                         env' = foldl2 rn_bndr2 env ps2 ps2
-                                         rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
-                                         eq_rhs       (_,r1) (_,r2) = eqExpr idu env' r1 r2
-eqExpr idu env (Case e1 v1 t1 a1)
-              (Case e2 v2 t2 a2) =  eqExpr idu env e1 e2
-                                 && tcEqTypeX env t1 t2                      
-                                 && equalLength a1 a2
-                                 && and (zipWith eq_alt a1 a2)
-                                 where
-                                   env' = rnBndr2 env v1 v2
-                                    eq_alt (c1,vs1,r1) (c2,vs2,r2) 
-                                       = c1==c2 && eqExpr idu (rnBndrs2 env' vs1  vs2) r1 r2
-eqExpr _ _ _ _ = False
-
-eq_note :: RnEnv2 -> Note -> Note -> Bool
-eq_note _ (SCC cc1)     (SCC cc2)      = cc1 == cc2
-eq_note _ (CoreNote s1) (CoreNote s2)  = s1 == s2
-eq_note _ _             _              = False
-\end{code}
-
-Auxiliary functions
-
-\begin{code}
-locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool
-locallyBoundL rn_env v = inRnEnvL rn_env v
-locallyBoundR rn_env v = inRnEnvR rn_env v
-
-
-expandUnfolding :: Unfolding -> Maybe CoreExpr
-expandUnfolding unfolding
-  | isExpandableUnfolding unfolding = Just (unfoldingTemplate unfolding)
-  | otherwise                      = Nothing
-\end{code}
-

 %************************************************************************
 %*                                                                     *
                    Rule-check the program                                                                              
 %************************************************************************
 %*                                                                     *
                    Rule-check the program