Remove very dead Java backend code.

[ghc-hetmet.git] / compiler / specialise / Rules.lhs

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 128d01f..f9d02e5 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -37,10 +37,10 @@ import CoreUtils        ( exprType, eqExpr )
 import PprCore         ( pprRules )
 import Type             ( Type )
 import TcType          ( tcSplitTyConApp_maybe )
+import Coercion
 import CoreTidy                ( tidyRules )
 import Id
 import IdInfo          ( SpecInfo( SpecInfo ) )
-import Var             ( Var )
 import VarEnv
 import VarSet
 import Name            ( Name, NamedThing(..) )
@@ -56,7 +56,6 @@ import Util
 import Data.List
 \end{code}
 
-
 Note [Overall plumbing for rules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * After the desugarer:
@@ -184,11 +183,13 @@ roughTopNames args = map roughTopName args
 
 roughTopName :: CoreExpr -> Maybe Name
 roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
-                         Just (tc,_) -> Just (getName tc)
-                         Nothing     -> Nothing
+                               Just (tc,_) -> Just (getName tc)
+                               Nothing     -> Nothing
+roughTopName (Coercion _) = Nothing 
 roughTopName (App f _) = roughTopName f
-roughTopName (Var f) | isGlobalId f = Just (idName f)
-                    | otherwise    = Nothing
+roughTopName (Var f)   | isGlobalId f  -- Note [Care with roughTopName]
+                       , isDataConWorkId f || idArity f > 0
+                       = Just (idName f)
 roughTopName _ = Nothing
 
 ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
@@ -209,6 +210,25 @@ ruleCantMatch (_       : ts) (_       : as) = ruleCantMatch ts as
 ruleCantMatch _             _              = False
 \end{code}
 
+Note [Care with roughTopName]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+    module M where { x = a:b }
+    module N where { ...f x...
+                     RULE f (p:q) = ... }
+You'd expect the rule to match, because the matcher can 
+look through the unfolding of 'x'.  So we must avoid roughTopName
+returning 'M.x' for the call (f x), or else it'll say "can't match"
+and we won't even try!!
+
+However, suppose we have
+        RULE g (M.h x) = ...
+        foo = ...(g (M.k v))....
+where k is a *function* exported by M.  We never really match
+functions (lambdas) except by name, so in this case it seems like
+a good idea to treat 'M.k' as a roughTopName of the call.
+
+    
 \begin{code}
 pprRulesForUser :: [CoreRule] -> SDoc
 -- (a) tidy the rules
@@ -340,7 +360,7 @@ lookupRule :: (Activation -> Bool)  -- When rule is active
 -- See Note [Extra args in rule matching]
 -- See comments on matchRule
 lookupRule is_active id_unf in_scope fn args rules
-  = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
+  = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
     case go [] rules of
        []     -> Nothing
        (m:ms) -> Just (findBest (fn,args) m ms)
@@ -605,10 +625,7 @@ match :: RuleEnv
 -- succeed in matching what looks like the template variable 'a' against 3.
 
 -- The Var case follows closely what happens in Unify.match
-match renv subst (Var v1) e2
-  | Just subst <- match_var renv subst v1 e2
-  = Just subst
-
+match renv subst (Var v1)    e2 = match_var renv subst v1 e2
 match renv subst (Note _ e1) e2 = match renv subst e1 e2
 match renv subst e1 (Note _ e2) = match renv subst e1 e2
       -- Ignore notes in both template and thing to be matched
@@ -694,15 +711,29 @@ match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
 
 match renv subst (Type ty1) (Type ty2)
   = match_ty renv subst ty1 ty2
+match renv subst (Coercion co1) (Coercion co2)
+  = match_co renv subst co1 co2
 
 match renv subst (Cast e1 co1) (Cast e2 co2)
-  = do { subst1 <- match_ty renv subst co1 co2
+  = do { subst1 <- match_co renv subst co1 co2
        ; match renv subst1 e1 e2 }
 
 -- Everything else fails
 match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
                     Nothing
 
+-------------
+match_co :: RuleEnv
+        -> RuleSubst
+        -> Coercion
+        -> Coercion
+        -> Maybe RuleSubst
+match_co renv subst (CoVarCo cv) co
+  = match_var renv subst cv (Coercion co)
+match_co _ _ co1 _ 
+  = pprTrace "match_co baling out" (ppr co1) Nothing
+
+-------------
 rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv
 rnMatchBndr2 renv subst x1 x2
   = renv { rv_lcl  = rnBndr2 rn_env x1 x2
@@ -1018,6 +1049,7 @@ ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
 ruleCheck _   (Var _)      = emptyBag
 ruleCheck _   (Lit _)      = emptyBag
 ruleCheck _   (Type _)      = emptyBag
+ruleCheck _   (Coercion _)  = emptyBag
 ruleCheck env (App f a)     = ruleCheckApp env (App f a) []
 ruleCheck env (Note _ e)    = ruleCheck env e
 ruleCheck env (Cast e _)    = ruleCheck env e