[project @ 2000-05-15 15:34:03 by keithw]

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

diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index f1578c2..9d77aaf 100644 (file)
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -5,16 +5,15 @@
 
 \begin{code}
 module Rules (
-       RuleBase, prepareRuleBase, lookupRule, addRule,
-       addIdSpecialisations,
+       RuleBase, prepareLocalRuleBase, prepareOrphanRuleBase,
+        unionRuleBase, lookupRule, addRule, addIdSpecialisations,
        ProtoCoreRule(..), pprProtoCoreRule,
-       orphanRule
+       localRule, orphanRule
     ) where
 
 #include "HsVersions.h"
 
 import CoreSyn         -- All of it
-import Const           ( Con(..), Literal(..) )
 import OccurAnal       ( occurAnalyseExpr, tagBinders, UsageDetails )
 import BinderInfo      ( markMany )
 import CoreFVs         ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
@@ -25,8 +24,8 @@ import Subst          ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
                          mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
                          unBindSubst, bindSubstList, unBindSubstList, substInScope
                        )
-import Id              ( Id, getIdUnfolding, zapLamIdInfo, 
-                         getIdSpecialisation, setIdSpecialisation,
+import Id              ( Id, idUnfolding, zapLamIdInfo, 
+                         idSpecialisation, setIdSpecialisation,
                          setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo
                        ) 
 import IdInfo          ( setSpecInfo, specInfo )
@@ -220,7 +219,7 @@ zapOccInfo bndr | isTyVar bndr = bndr
 \end{code}
 
 \begin{code}
-type Matcher result =  IdOrTyVarSet            -- Template variables
+type Matcher result =  VarSet                  -- Template variables
                    -> (Subst -> Maybe result)  -- Continuation if success
                    -> Subst  -> Maybe result   -- Substitution so far -> result
 -- The *SubstEnv* in these Substs apply to the TEMPLATE only 
@@ -253,9 +252,9 @@ match (Var v1) e2 tpl_vars kont subst
 
        other -> match_fail
 
-match (Con c1 es1) (Con c2 es2) tpl_vars kont subst
-  | c1 == c2
-  = matches es1 es2 tpl_vars kont subst
+match (Lit lit1) (Lit lit2) tpl_vars kont subst
+  | lit1 == lit2
+  = kont subst
 
 match (App f1 a1) (App f2 a2) tpl_vars kont subst
   = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
@@ -325,7 +324,7 @@ match e1 (Var v2) tpl_vars kont subst
   | isCheapUnfolding unfolding
   = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
   where
-    unfolding = getIdUnfolding v2
+    unfolding = idUnfolding v2
 
 
 -- We can't cope with lets in the template
@@ -439,7 +438,7 @@ addIdSpecialisations id spec_stuff
   = setIdSpecialisation id new_rules
   where
     rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id))
-    new_rules = foldr add (getIdSpecialisation id) spec_stuff
+    new_rules = foldr add (idSpecialisation id) spec_stuff
     add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs)
 \end{code}
 
@@ -462,12 +461,15 @@ pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule
 
 lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
 lookupRule in_scope fn args
-  = case getIdSpecialisation fn of
+  = case idSpecialisation fn of
        Rules rules _ -> matchRules in_scope rules args
 
+localRule :: ProtoCoreRule -> Bool
+localRule (ProtoCoreRule local _ _) = local
+
 orphanRule :: ProtoCoreRule -> Bool
 -- An "orphan rule" is one that is defined in this 
--- module, but of ran *imported* function.  We need
+-- module, but for an *imported* function.  We need
 -- to track these separately when generating the interface file
 orphanRule (ProtoCoreRule local fn _)
   = local && not (isLocallyDefined fn)
@@ -485,17 +487,32 @@ type RuleBase = (IdSet,           -- Imported Ids that have rules attached
                 IdSet)         -- Ids (whether local or imported) mentioned on 
                                -- LHS of some rule; these should be black listed
 
+unionRuleBase (rule_ids1, black_ids1) (rule_ids2, black_ids2)
+  = (plusUFM_C merge_rules rule_ids1 rule_ids2,
+     unionVarSet black_ids1 black_ids2)
+  where
+    merge_rules id1 id2 = let rules1 = idSpecialisation id1
+                              rules2 = idSpecialisation id2
+                              new_rules = foldl (addRule id1) rules1 (rulesRules rules2)
+                          in
+                          setIdSpecialisation id1 new_rules
+
+-- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
+-- It attaches those rules that are for local Ids to their binders, and
+-- returns the remainder attached to Ids in an IdSet.  It also returns
+-- Ids mentioned on LHS of some rule; these should be blacklisted.
+
 -- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
 -- so that the opportunity to apply the rule isn't lost too soon
 
-prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
-prepareRuleBase binds all_rules
-  = (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs))
+prepareLocalRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
+prepareLocalRuleBase binds local_rules
+  = (map zap_bind binds, (imported_id_rule_ids, rule_lhs_fvs))
   where
-    (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) all_rules
-    imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
+    (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) local_rules
+    imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
 
-       -- rule_fvs is the set of all variables mentioned in rules
+       -- rule_fvs is the set of all variables mentioned in this module's rules
     rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids
 
        -- Attach the rules for each locally-defined Id to that Id.
@@ -533,5 +550,12 @@ add_rule (ProtoCoreRule _ id rule)
        -- Find *all* the free Ids of the LHS, not just
        -- locally defined ones!!
 
-addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule)
+addRuleToId id rule = setIdSpecialisation id (addRule id (idSpecialisation id) rule)
+
+-- prepareOrphanRuleBase does exactly the same as prepareLocalRuleBase, except that
+-- it assumes that none of the rules can be attached to local Ids.
+
+prepareOrphanRuleBase :: [ProtoCoreRule] -> RuleBase
+prepareOrphanRuleBase imported_rules
+  = foldr add_rule (emptyVarSet, emptyVarSet) imported_rules
 \end{code}