Trim imports, reformatting

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

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index b12147d..35a0bdd 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -10,6 +10,8 @@ module Rules (
 
        mkSpecInfo, extendSpecInfo, addSpecInfo,
        rulesOfBinds, addIdSpecialisations, 
+       
+       matchN,
 
         lookupRule, mkLocalRule, roughTopNames
     ) where
@@ -23,6 +25,7 @@ import CoreUnfold     ( isCheapUnfolding, unfoldingTemplate )
 import CoreUtils       ( tcEqExprX )
 import PprCore         ( pprRules )
 import Type            ( TvSubstEnv )
+import Coercion         ( coercionKind )
 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )
 import Id              ( Id, idUnfolding, isLocalId, isGlobalId, idName,
@@ -34,7 +37,7 @@ import VarEnv         ( IdEnv, InScopeSet, emptyTidyEnv,
                          emptyVarEnv, lookupVarEnv, extendVarEnv, 
                          nukeRnEnvL, mkRnEnv2, rnOccR, rnOccL, inRnEnvR,
                          rnBndrR, rnBndr2, rnBndrL, rnBndrs2,
-                         rnInScope, extendRnInScopeList )
+                         rnInScope, extendRnInScopeList, lookupRnInScope )
 import VarSet
 import Name            ( Name, NamedThing(..), nameOccName )
 import NameEnv
@@ -239,7 +242,7 @@ findBest :: (Id, [CoreExpr])
 findBest target (rule,ans)   [] = (rule,ans)
 findBest target (rule1,ans1) ((rule2,ans2):prs)
   | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
-  | rule2 `isMoreSpecific` rule1 = findBest target (rule1,ans1) prs
+  | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
 #ifdef DEBUG
   | otherwise = pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
                         (vcat [ptext SLIT("Expression to match:") <+> ppr fn <+> sep (map ppr args),
@@ -368,7 +371,7 @@ matchN in_scope tmpl_vars tmpl_es target_es
 --   from nested matches; see the Let case of match, below
 --
 type SubstEnv   = (TvSubstEnv, IdSubstEnv, OrdList CoreBind)
-type IdSubstEnv = IdEnv    CoreExpr            
+type IdSubstEnv = IdEnv CoreExpr               
 
 emptySubstEnv :: SubstEnv
 emptySubstEnv = (emptyVarEnv, emptyVarEnv, nilOL)
@@ -414,10 +417,18 @@ match menv subst (Var v1) e2
 -- (Its occurrence information is not necessarily up to date,
 --  so we don't use it.)
 match menv subst e1 (Var v2)
-  | isCheapUnfolding unfolding
+  | not (inRnEnvR rn_env v2),
+       -- If v2 is in the RnEnvR, then it's locally bound and can't
+       -- have an unfolding. We must make this check because if it
+       -- is locally bound we must not look it up in the in-scope set
+       -- E.g.         (\x->x) where x is already in scope
+    isCheapUnfolding unfolding
   = match menv subst e1 (unfoldingTemplate unfolding)
   where
-    unfolding = idUnfolding v2
+    rn_env    = me_env menv
+    unfolding = idUnfolding (lookupRnInScope rn_env v2)
+       -- Notice that we look up v2 in the in-scope set
+       -- See Note [Lookup in-scope]
 
 match menv subst (Lit lit1) (Lit lit2)
   | lit1 == lit2
@@ -451,14 +462,16 @@ match menv subst e1 (Lam x2 e2)
 match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
   = do { subst1 <- match_ty menv subst ty1 ty2
        ; subst2 <- match menv subst1 e1 e2
-       ; let menv' = menv { me_env = rnBndr2 (me_env menv) x2 x2 }
+       ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
        ; match_alts menv' subst2 alts1 alts2   -- Alts are both sorted
        }
 
 match menv subst (Type ty1) (Type ty2)
   = match_ty menv subst ty1 ty2
 
-match menv subst (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
+match menv subst (Cast e1 co1) (Cast e2 co2)
+  | (from1, to1) <- coercionKind co1
+  , (from2, to2) <- coercionKind co2
   = do { subst1 <- match_ty menv subst  to1   to2
        ; subst2 <- match_ty menv subst1 from1 from2
        ; match menv subst2 e1 e2 }
@@ -534,7 +547,7 @@ 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
+               | otherwise     -- No renaming to do on e2
                -> Just (tv_subst, extendVarEnv id_subst v1 e2, binds)
 
        Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2 
@@ -591,6 +604,42 @@ match_ty menv (tv_subst, id_subst, binds) ty1 ty2
 \end{code}
 
 
+Note [Lookup in-scope]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider this example
+       foo :: Int -> Maybe Int -> Int
+       foo 0 (Just n) = n
+       foo m (Just n) = foo (m-n) (Just n)
+
+SpecConstr sees this fragment:
+
+       case w_smT of wild_Xf [Just A] {
+         Data.Maybe.Nothing -> lvl_smf;
+         Data.Maybe.Just n_acT [Just S(L)] ->
+           case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
+           $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
+           }};
+
+and correctly generates the rule
+
+       RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
+                                         sc_snn :: GHC.Prim.Int#}
+         $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
+         = $s$wfoo_sno y_amr sc_snn ;]
+
+BUT we must ensure that this rule matches in the original function!
+Note that the call to $wfoo is
+           $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
+
+During matching we expand wild_Xf to (Just n_acT).  But then we must also
+expand n_acT to (I# y_amr).  And we can only do that if we look up n_acT
+in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding
+at all. 
+
+That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
+is so important.
+
+
 %************************************************************************
 %*                                                                     *
 \subsection{Checking a program for failing rule applications}