[project @ 1999-10-29 13:53:37 by sof]

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

diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index c0e05c5..e27b0e2 100644 (file)
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -17,12 +17,12 @@ import CoreSyn              -- All of it
 import OccurAnal       ( occurAnalyseExpr, tagBinders, UsageDetails )
 import BinderInfo      ( markMany )
 import CoreFVs         ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
-import CoreUnfold      ( Unfolding(..) )
-import CoreUtils       ( whnfOrBottom, eqExpr )
+import CoreUnfold      ( isCheapUnfolding, unfoldingTemplate )
+import CoreUtils       ( eqExpr )
 import PprCore         ( pprCoreRule )
 import Subst           ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
                          mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
-                         unBindSubst, bindSubstList, unBindSubstList,
+                         unBindSubst, bindSubstList, unBindSubstList, substInScope
                        )
 import Id              ( Id, getIdUnfolding, 
                          getIdSpecialisation, setIdSpecialisation,
@@ -142,8 +142,8 @@ matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExp
 --     (\x->E) matches (\x->F x)
 
 
-matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
- = go tpl_args args emptySubst
+matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args
+  = go tpl_args args emptySubst
        -- We used to use the in_scope set, but I don't think that's necessary
        -- After all, the result is going to be simplified again with that in_scope set
  where
@@ -159,7 +159,17 @@ matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
 
        -- One tiresome way to terminate: check for excess unmatched
        -- template arguments
-   go tpl_args          []         subst 
+   go tpl_args          []         subst = Nothing     -- Failure
+
+
+{-     The code below tries to match even if there are more 
+       template args than real args.
+
+       I now think this is probably a bad idea.
+       Should the template (map f xs) match (map g)?  I think not.
+       For a start, in general eta expansion wastes work.
+       SLPJ July 99
+
       = case eta_complete tpl_args (mkVarSet leftovers) of
            Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs), 
                                     mk_result_args subst done)
@@ -188,6 +198,7 @@ matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
                Nothing    -> Nothing
 
    eta_complete other vars = Nothing
+-}
 
    -----------------------
    mk_result_args subst vs = map go vs
@@ -198,6 +209,7 @@ matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
                        Just (DoneTy ty) -> Type ty
                        -- Substitution should bind them all!
 
+
 zapOccInfo bndr | isTyVar bndr = bndr
                | otherwise    = maybeModifyIdInfo zapLamIdInfo bndr
 \end{code}
@@ -257,7 +269,16 @@ match (Lam x1 e1) e2 tpl_vars kont subst
 --                     iff   M y     ~  N
 -- Remembering that by (A), y can't be free in M, we get this
 match e1 (Lam x2 e2) tpl_vars kont subst
-  = bind [x2] [x2] (match (App e1 (mkVarArg x2)) e2) tpl_vars kont subst
+  = bind [new_id] [x2] (match (App e1 (mkVarArg new_id)) e2) tpl_vars kont subst
+  where
+    new_id = uniqAway (substInScope subst) x2
+       -- This uniqAway is actually needed.  Here's the example:
+       --  rule:       foldr (mapFB (:) f) [] = mapList
+       --  target:     foldr (\x. mapFB k f x) []
+       --            where
+       --              k = \x. mapFB ... x
+       -- The first \x is ok, but when we inline k, hoping it might
+       -- match (:) we find a second \x.
 
 match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
   = match e1 e2 tpl_vars case_kont subst
@@ -296,12 +317,11 @@ match e1 (Let bind e2) tpl_vars kont subst
 -- (Its occurrence information is not necessarily up to date,
 --  so we don't use it.)
 match e1 (Var v2) tpl_vars kont subst
-  = case getIdUnfolding v2 of
-       CoreUnfolding form guidance unfolding
-          |  whnfOrBottom form
-          -> match e1 unfolding tpl_vars kont subst
+  | isCheapUnfolding unfolding
+  = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
+  where
+    unfolding = getIdUnfolding v2
 
-       other -> match_fail
 
 -- We can't cope with lets in the template
 
@@ -332,7 +352,7 @@ bind :: [CoreBndr]  -- Template binders
 -- We rename x to y in the template... but then erroneously
 -- match y against y.  But this can't happen because of (A)
 bind vs1 vs2 matcher tpl_vars kont subst
-  = ASSERT( all not_in_subst vs1) 
+  = WARN( not (all not_in_subst vs1), bug_msg )
     matcher tpl_vars kont' subst'
   where
     kont' subst'' = kont (unBindSubstList subst'' vs1 vs2)
@@ -340,6 +360,7 @@ bind vs1 vs2 matcher tpl_vars kont subst
 
        -- The unBindSubst relies on no shadowing in the template
     not_in_subst v = not (maybeToBool (lookupSubst subst v))
+    bug_msg = sep [ppr vs1, ppr vs2]
 
 ----------------------------------------
 match_ty ty1 ty2 tpl_vars kont subst