[project @ 2005-03-07 16:46:08 by simonpj]

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

diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index e09dc22..e66e048 100644 (file)
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -9,7 +9,7 @@ module Rules (
        extendRuleBaseList, 
        ruleBaseIds, pprRuleBase, ruleCheckProgram,
 
-        lookupRule, addRule, addIdSpecialisations
+        lookupRule, addRule, addRules, addIdSpecialisations
     ) where
 
 #include "HsVersions.h"
@@ -19,20 +19,18 @@ import OccurAnal    ( occurAnalyseRule )
 import CoreFVs         ( exprFreeVars, exprsFreeVars, ruleRhsFreeVars )
 import CoreUnfold      ( isCheapUnfolding, unfoldingTemplate )
 import CoreUtils       ( tcEqExprX )
+import Type            ( Type )
 import CoreTidy                ( pprTidyIdRules )
-import Subst           ( IdSubstEnv, SubstResult(..) )
-import Id              ( Id, idUnfolding, idSpecialisation, setIdSpecialisation ) 
+import Id              ( Id, idUnfolding, isLocalId, idSpecialisation, setIdSpecialisation ) 
 import Var             ( Var )
 import VarSet
 import VarEnv
-import TcType          ( TvSubstEnv )
 import Unify           ( tcMatchTyX, MatchEnv(..) )
 import BasicTypes      ( Activation, CompilerPhase, isActive )
 
 import Outputable
 import FastString
 import Maybe           ( isJust, fromMaybe )
-import Util            ( sortLe )
 import Bag
 import List            ( isPrefixOf )
 \end{code}
@@ -157,12 +155,27 @@ matchN in_scope tmpl_vars tmpl_es target_es
                                Just ty         -> Type ty
                                Nothing         -> unbound tmpl_var
        | otherwise        = case lookupVarEnv id_subst tmpl_var of
-                               Just (DoneEx e) -> e
-                               other           -> unbound tmpl_var
+                               Just e -> e
+                               other  -> unbound tmpl_var
  
     unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
+\end{code}
+
 
-emptySubstEnv :: (TvSubstEnv, IdSubstEnv)
+       ---------------------------------------------
+               The inner workings of matching
+       ---------------------------------------------
+
+\begin{code}
+-- These two definitions are not the same as in Subst,
+-- but they simple and direct, and purely local to this module
+-- The third, for TvSubstEnv, is the same as in VarEnv, but repeated here
+-- for uniformity with IdSubstEnv
+type SubstEnv   = (TvSubstEnv, IdSubstEnv)     
+type IdSubstEnv = IdEnv    CoreExpr            
+type TvSubstEnv = TyVarEnv Type
+
+emptySubstEnv :: SubstEnv
 emptySubstEnv = (emptyVarEnv, emptyVarEnv)
 
 
@@ -176,10 +189,10 @@ emptySubstEnv = (emptyVarEnv, emptyVarEnv)
 
 
 match :: MatchEnv
-      -> (TvSubstEnv, IdSubstEnv)
+      -> SubstEnv
       -> CoreExpr              -- Template
       -> CoreExpr              -- Target
-      -> Maybe (TvSubstEnv, IdSubstEnv)
+      -> Maybe SubstEnv
 
 -- See the notes with Unify.match, which matches types
 -- Everything is very similar for terms
@@ -205,10 +218,10 @@ match menv subst@(tv_subst, id_subst) (Var v1) e2
                -- e.g. match forall a. (\x-> a x) against (\y. y y)
 
                | otherwise
-               -> Just (tv_subst, extendVarEnv id_subst v1 (DoneEx e2))
+               -> Just (tv_subst, extendVarEnv id_subst v1 e2)
 
-       Just (DoneEx e2') | tcEqExprX (nukeRnEnvL rn_env) e2' e2 
-                         -> Just subst
+       Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2 
+                -> Just subst
 
        other -> Nothing
 
@@ -263,7 +276,7 @@ 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 }
-       ; match_alts menv' subst2 (sortLe le_alt alts1) (sortLe le_alt alts2)
+       ; match_alts menv' subst2 alts1 alts2   -- Alts are both sorted
        }
 
 match menv subst (Type ty1) (Type ty2)
@@ -295,10 +308,10 @@ match menv subst e1 e2 = Nothing
 
 ------------------------------------------
 match_alts :: MatchEnv
-      -> (TvSubstEnv, IdSubstEnv)
+      -> SubstEnv
       -> [CoreAlt]             -- Template
       -> [CoreAlt]             -- Target
-      -> Maybe (TvSubstEnv, IdSubstEnv)
+      -> Maybe SubstEnv
 match_alts menv subst [] []
   = return subst
 match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
@@ -311,8 +324,6 @@ match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
 
 match_alts menv subst alts1 alts2 
   = Nothing
-
-le_alt (con1, _, _) (con2, _, _) = con1 <= con2
 \end{code}
 
 Matching Core types: use the matcher in TcType.
@@ -336,7 +347,8 @@ match_ty menv (tv_subst, id_subst) ty1 ty2
 %************************************************************************
 
 \begin{code}
-addRule :: Id -> CoreRules -> CoreRule -> CoreRules
+addRules :: Id -> CoreRules -> [CoreRule] -> CoreRules
+addRule  :: Id -> CoreRules -> CoreRule -> CoreRules
 
 -- Add a new rule to an existing bunch of rules.
 -- The rules are for the given Id; the Id argument is needed only
@@ -350,6 +362,8 @@ addRule :: Id -> CoreRules -> CoreRule -> CoreRules
 -- We make no check for rules that unify without one dominating
 -- the other.   Arguably this would be a bug.
 
+addRules id rules rule_list = foldl (addRule id) rules rule_list
+
 addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _)
   = Rules (rule:rules) rhs_fvs
        -- Put it at the start for lack of anything better
@@ -382,7 +396,7 @@ addIdSpecialisations :: Id -> [CoreRule] -> Id
 addIdSpecialisations id rules
   = setIdSpecialisation id new_specs
   where
-    new_specs = foldl (addRule id) (idSpecialisation id) rules
+    new_specs = addRules id (idSpecialisation id) rules
 \end{code}
 
 
@@ -393,11 +407,17 @@ addIdSpecialisations id rules
 %************************************************************************
 
 \begin{code}
-lookupRule :: (Activation -> Bool) -> InScopeSet
+lookupRule :: (Activation -> Bool) 
+          -> InScopeSet
+          -> RuleBase          -- Ids from other modules
           -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
-lookupRule is_active in_scope fn args
-  = case idSpecialisation fn of
+lookupRule is_active in_scope rules fn args
+  = case idSpecialisation fn' of
        Rules rules _ -> matchRules is_active in_scope rules args
+  where
+    fn' | isLocalId fn                                      = fn
+       | Just ext_fn <- lookupVarSet (ruleBaseIds rules) fn = ext_fn
+       | otherwise                                          = fn
 \end{code}
 
 
@@ -450,7 +470,6 @@ ruleCheck env (App f a)     = ruleCheckApp env (App f a) []
 ruleCheck env (Note n e)    = ruleCheck env e
 ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e
 ruleCheck env (Lam b e)     = ruleCheck env e
--- gaw 2004
 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` 
                                unionManyBags [ruleCheck env r | (_,_,r) <- as]