X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FRules.lhs;h=4f538599202d1cfac7f6261b5efd8de3a4d15477;hb=59c796f8e77325d35f29ddd3e724bfa780466d40;hp=b8b00ec45381c561e7159f7beb4e9e9757e4becc;hpb=7d841483081735f5f906a6bb5e80249d97f3226b;p=ghc-hetmet.git

diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index b8b00ec..4f53859 100644
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -6,9 +6,8 @@
 \begin{code}
 module Rules (
 	RuleBase, emptyRuleBase, 
-	extendRuleBase, extendRuleBaseList, addRuleBaseFVs, 
-	ruleBaseIds, ruleBaseFVs,
-	pprRuleBase, ruleCheckProgram,
+	extendRuleBaseList, 
+	ruleBaseIds, pprRuleBase, ruleCheckProgram,
 
         lookupRule, addRule, addIdSpecialisations
     ) where
@@ -17,11 +16,10 @@ module Rules (
 
 import CoreSyn		-- All of it
 import OccurAnal	( occurAnalyseRule )
-import CoreFVs		( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds )
+import CoreFVs		( exprFreeVars, ruleRhsFreeVars )
 import CoreUnfold	( isCheapUnfolding, unfoldingTemplate )
-import CoreTidy		( tidyIdRules )
 import CoreUtils	( eqExpr )
-import PprCore		( pprIdRules )
+import CoreTidy		( pprTidyIdRules )
 import Subst		( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
 			  substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet,
 			  bindSubstList, unBindSubstList, substInScope, uniqAway
@@ -35,8 +33,9 @@ import qualified TcType ( match )
 import BasicTypes	( Activation, CompilerPhase, isActive )
 
 import Outputable
+import FastString
 import Maybe		( isJust, isNothing, fromMaybe )
-import Util		( sortLt )
+import Util		( sortLe )
 import Bag
 import List		( isPrefixOf )
 \end{code}
@@ -293,7 +292,7 @@ match e1 (Lam x2 e2) tpl_vars kont subst
 match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
   = match e1 e2 tpl_vars case_kont subst
   where
-    case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2))
+    case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLe le_alt alts2))
 				     tpl_vars kont subst
 
 match (Type ty1) (Type ty2) tpl_vars kont subst
@@ -348,7 +347,7 @@ match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst
 		 subst
 match_alts alts1 alts2 tpl_vars kont subst = match_fail
 
-lt_alt (con1, _, _) (con2, _, _) = con1 < con2
+le_alt (con1, _, _) (con2, _, _) = con1 <= con2
 
 ----------------------------------------
 bind :: [CoreBndr]	-- Template binders
@@ -373,14 +372,6 @@ bind vs1 vs2 matcher tpl_vars kont subst
     bug_msg = sep [ppr vs1, ppr vs2]
 
 ----------------------------------------
-matches [] [] tpl_vars kont subst 
-  = kont subst
-matches (e:es) (e':es') tpl_vars kont subst
-  = match e e' tpl_vars (matches es es' tpl_vars kont) subst
-matches es es' tpl_vars kont subst 
-  = match_fail
-
-----------------------------------------
 mkVarArg :: CoreBndr -> CoreArg
 mkVarArg v | isId v    = Var v
 	   | otherwise = Type (mkTyVarTy v)
@@ -542,7 +533,7 @@ ruleCheckFun (phase, pat) fn args
   where
     name_match_rules = case idSpecialisation fn of
 			  Rules rules _ -> filter match rules
-    match rule = pat `isPrefixOf` _UNPK_ (ruleName rule)
+    match rule = pat `isPrefixOf` unpackFS (ruleName rule)
 
 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
 ruleAppCheck_help phase fn args rules
@@ -555,8 +546,10 @@ ruleAppCheck_help phase fn args rules
 
     check_rule rule = rule_herald rule <> colon <+> rule_info rule
 
-    rule_herald (BuiltinRule name _) = text "Builtin rule" <+> doubleQuotes (ptext name)
-    rule_herald (Rule name _ _ _ _)  = text "Rule" <+> doubleQuotes (ptext name)
+    rule_herald (BuiltinRule name _) = 
+	ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
+    rule_herald (Rule name _ _ _ _)  = 
+	ptext SLIT("Rule") <+> doubleQuotes (ftext name)
 
     rule_info rule
 	| Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args
@@ -592,44 +585,27 @@ data RuleBase = RuleBase
 		    IdSet	-- Ids with their rules in their specialisations
 				-- Held as a set, so that it can simply be the initial
 				-- in-scope set in the simplifier
-
-		    IdSet	-- Ids (whether local or imported) mentioned on 
-				-- LHS of some rule; these should be black listed
-
 	-- This representation is a bit cute, and I wonder if we should
 	-- change it to use (IdEnv CoreRule) which seems a bit more natural
 
-ruleBaseIds (RuleBase ids _) = ids
-ruleBaseFVs (RuleBase _ fvs) = fvs
-
-emptyRuleBase = RuleBase emptyVarSet emptyVarSet
-
-addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase
-addRuleBaseFVs (RuleBase rules fvs) extra_fvs 
-  = RuleBase rules (fvs `unionVarSet` extra_fvs)
+ruleBaseIds (RuleBase ids) = ids
+emptyRuleBase = RuleBase emptyVarSet
 
 extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
 extendRuleBaseList rule_base new_guys
   = foldl extendRuleBase rule_base new_guys
 
 extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase
-extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule)
+extendRuleBase (RuleBase rule_ids) (id, rule)
   = RuleBase (extendVarSet rule_ids new_id)
-	     (rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
   where
-    new_id = setIdSpecialisation id (addRule id old_rules rule)
-
+    new_id    = setIdSpecialisation id (addRule id old_rules rule)
     old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
 	-- Get the old rules from rule_ids if the Id is already there, but
 	-- if not, use the Id from the incoming rule.  If may be a PrimOpId,
 	-- in which case it may have rules in its belly already.  Seems
 	-- dreadfully hackoid.
 
-    lhs_fvs = ruleLhsFreeIds rule
-	-- Finds *all* the free Ids of the LHS, not just
-	-- locally defined ones!!
-
 pprRuleBase :: RuleBase -> SDoc
-pprRuleBase (RuleBase rules _) = vcat [ pprIdRules (tidyIdRules id)
-				      | id <- varSetElems rules ]
+pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]
 \end{code}