[project @ 2001-06-25 08:09:57 by simonpj]
[ghc-hetmet.git] / ghc / compiler / specialise / Rules.lhs
index 8406b0a..591e4db 100644 (file)
@@ -5,43 +5,36 @@
 
 \begin{code}
 module Rules (
-       RuleBase, prepareRuleBase, lookupRule, 
-       addIdSpecialisations,
-       ProtoCoreRule(..), pprProtoCoreRule,
-       orphanRule
+       RuleBase, emptyRuleBase, 
+       extendRuleBase, extendRuleBaseList, addRuleBaseFVs, 
+       ruleBaseIds, ruleBaseFVs,
+       pprRuleBase,
+
+        lookupRule, addRule, addIdSpecialisations
     ) where
 
 #include "HsVersions.h"
 
 import CoreSyn         -- All of it
-import OccurAnal       ( occurAnalyseExpr, tagBinders, UsageDetails )
-import BinderInfo      ( markMany )
-import CoreFVs         ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
+import OccurAnal       ( occurAnalyseRule )
+import CoreFVs         ( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds )
 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,
+import Subst           ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
+                         substEnv, setSubstEnv, emptySubst, isInScope,
+                         bindSubstList, unBindSubstList, substInScope, uniqAway
                        )
-import Id              ( Id, getIdUnfolding, 
-                         getIdSpecialisation, setIdSpecialisation,
-                         setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo
-                       ) 
-import IdInfo          ( zapLamIdInfo, setSpecInfo, specInfo )
-import Name            ( Name, isLocallyDefined )
-import Var             ( isTyVar, isId )
+import Id              ( Id, idUnfolding, idSpecialisation, setIdSpecialisation ) 
+import Var             ( isId )
 import VarSet
 import VarEnv
-import Type            ( mkTyVarTy, getTyVar_maybe )
-import qualified Unify ( match )
-import CmdLineOpts     ( opt_D_dump_simpl, opt_D_verbose_core2core )
+import TcType          ( mkTyVarTy )
+import qualified TcType ( match )
+import TypeRep         ( Type(..) )    -- Can see type representation for matching
 
-import UniqFM
-import ErrUtils                ( dumpIfSet )
 import Outputable
-import Maybes          ( maybeToBool )
-import List            ( partition )
+import Maybe           ( isJust, isNothing, fromMaybe )
 import Util            ( sortLt )
 \end{code}
 
@@ -88,7 +81,7 @@ where pi' :: Lift Int# is the specialised version of pi.
 %************************************************************************
 
 \begin{code}
-matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
 -- See comments on matchRule
 matchRules in_scope [] args = Nothing
 matchRules in_scope (rule:rules) args
@@ -97,11 +90,11 @@ matchRules in_scope (rule:rules) args
        Nothing     -> matchRules in_scope rules args
 
 
-matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
 
--- If (matchRule rule args) returns Just (name,rhs,args')
+-- If (matchRule rule args) returns Just (name,rhs)
 -- then (f args) matches the rule, and the corresponding
--- rewritten RHS is (rhs args').
+-- rewritten RHS is rhs
 --
 -- The bndrs and rhs is occurrence-analysed
 --
@@ -116,7 +109,7 @@ matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExp
 --              map (f.g) x)           -- rhs
 --       
 -- Then the call: matchRule the_rule [e1,map e2 e3]
---       = Just ("map/map", \f,g,x -> rhs, [e1,e2,e3])
+--       = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
 --
 -- Any 'surplus' arguments in the input are simply put on the end
 -- of the output.
@@ -142,8 +135,10 @@ 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@(BuiltinRule match_fn) args = match_fn args
+
+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
@@ -154,14 +149,25 @@ matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
    go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
 
        -- Two easy ways to terminate
-   go []                []         subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars)
-   go []                args       subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars ++ args)
+   go [] []        subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars)
+   go [] args      subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars `mkApps` args)
 
        -- One tiresome way to terminate: check for excess unmatched
        -- template arguments
-   go tpl_args          []         subst = Nothing     -- Failure
+   go tpl_args []   subst = Nothing    -- Failure
+
+
+   -----------------------
+   app_match subst fn vs = foldl go fn vs
+       where   
+         senv    = substEnv subst
+         go fn v = case lookupSubstEnv senv v of
+                       Just (DoneEx ex)  -> fn `App` ex 
+                       Just (DoneTy ty)  -> fn `App` Type ty
+                       -- Substitution should bind them all!
 
 
+   -----------------------
 {-     The code below tries to match even if there are more 
        template args than real args.
 
@@ -175,7 +181,7 @@ matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
                                     mk_result_args subst done)
            Nothing         -> Nothing  -- Failure
       where
-       (done, leftovers) = partition (\v -> maybeToBool (lookupSubstEnv subst_env v))
+       (done, leftovers) = partition (\v -> isJust (lookupSubstEnv subst_env v))
                                      (map zapOccInfo tpl_vars)
                -- Zap the occ info 
        subst_env = substEnv subst
@@ -198,24 +204,15 @@ 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
-       where   
-         senv = substEnv subst
-         go v = case lookupSubstEnv senv v of
-                       Just (DoneEx ex) -> ex
-                       Just (DoneTy ty) -> Type ty
-                       -- Substitution should bind them all!
 
 
 zapOccInfo bndr | isTyVar bndr = bndr
-               | otherwise    = maybeModifyIdInfo zapLamIdInfo bndr
+               | otherwise    = zapLamIdInfo 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 
@@ -241,16 +238,16 @@ match (Var v1) e2 tpl_vars kont subst
                         kont (extendSubst subst v1 (DoneEx e2))
 
 
-               | eqExpr (Var v1) e2             -> kont subst
+               | eqExpr (Var v1) e2       -> kont subst
                        -- v1 is not a template variable, so it must be a global constant
 
-       Just (DoneEx e2')  | eqExpr e2'       e2 -> kont subst
+       Just (DoneEx e2')  | eqExpr e2' e2 -> 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
@@ -269,7 +266,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
@@ -311,7 +317,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
@@ -343,20 +349,15 @@ 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)
     subst'        = bindSubstList subst vs1 vs2
 
        -- The unBindSubst relies on no shadowing in the template
-    not_in_subst v = not (maybeToBool (lookupSubst subst v))
-
-----------------------------------------
-match_ty ty1 ty2 tpl_vars kont subst
-  = case Unify.match ty1 ty2 tpl_vars Just (substEnv subst) of
-       Nothing    -> match_fail
-       Just senv' -> kont (setSubstEnv subst senv') 
+    not_in_subst v = isNothing (lookupSubst subst v)
+    bug_msg = sep [ppr vs1, ppr vs2]
 
 ----------------------------------------
 matches [] [] tpl_vars kont subst 
@@ -372,6 +373,22 @@ mkVarArg v | isId v    = Var v
           | otherwise = Type (mkTyVarTy v)
 \end{code}
 
+Matching Core types: use the matcher in TcType.
+Notice that we treat newtypes as opaque.  For example, suppose 
+we have a specialised version of a function at a newtype, say 
+       newtype T = MkT Int
+We only want to replace (f T) with f', not (f Int).
+
+\begin{code}
+----------------------------------------
+match_ty ty1 ty2 tpl_vars kont subst
+  = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst)
+  where
+    kont' senv = kont (setSubstEnv subst senv) 
+\end{code}
+
+
+
 %************************************************************************
 %*                                                                     *
 \subsection{Adding a new rule}
@@ -379,7 +396,7 @@ mkVarArg v | isId v    = Var v
 %************************************************************************
 
 \begin{code}
-addRule :: Id -> CoreRules -> CoreRule -> CoreRules
+addRule :: CoreRules -> Id -> CoreRule -> CoreRules
 
 -- Insert the new rule just before a rule that is *less specific*
 -- than the new one; or at the end if there isn't such a one.
@@ -389,39 +406,40 @@ addRule :: Id -> CoreRules -> CoreRule -> CoreRules
 -- We make no check for rules that unify without one dominating
 -- the other.   Arguably this would be a bug.
 
-addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs)
-  = Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs)
-  where
-    new_rule = Rule str tpl_vars' tpl_args rhs'
-               -- Add occ info to tpl_vars, rhs
-
-    (rhs_uds, rhs')      = occurAnalyseExpr isLocallyDefined rhs
-    (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars
-
-    insert []                                      = [new_rule]
-    insert (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
-                       | otherwise                 = rule : insert rules
-
-    new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args)
-
-    tpl_var_set = mkVarSet tpl_vars'
-       -- Actually we should probably include the free vars of tpl_args,
-       -- but I can't be bothered
+addRule (Rules rules rhs_fvs) id rule@(BuiltinRule _)
+  = Rules (rule:rules) rhs_fvs
+       -- Put it at the start for lack of anything better
 
-    new_rhs_fvs = (exprFreeVars rhs' `minusVarSet` tpl_var_set) `delVarSet` id
+addRule (Rules rules rhs_fvs) id rule
+  = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
+  where
+    new_rule    = occurAnalyseRule rule
+    new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id
        -- Hack alert!
        -- Don't include the Id in its own rhs free-var set.
        -- Otherwise the occurrence analyser makes bindings recursive
        -- that shoudn't be.  E.g.
        --      RULE:  f (f x y) z  ==>  f x (f y z)
 
-addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id
-addIdSpecialisations id spec_stuff
-  = setIdSpecialisation id new_rules
+insertRule rules new_rule@(Rule _ tpl_vars tpl_args _)
+  = go rules
   where
-    rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id))
-    new_rules = foldr add (getIdSpecialisation id) spec_stuff
-    add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs)
+    tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
+       -- Actually we should probably include the free vars of tpl_args,
+       -- but I can't be bothered
+
+    go []                                      = [new_rule]
+    go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
+                   | otherwise                 = rule : go rules
+
+    new_is_more_specific rule = isJust (matchRule tpl_var_set rule tpl_args)
+
+addIdSpecialisations :: Id -> [CoreRule] -> Id
+addIdSpecialisations id rules
+  = setIdSpecialisation id new_specs
+  where
+    new_specs = foldr add (idSpecialisation id) rules
+    add rule rules = addRule rules id rule
 \end{code}
 
 
@@ -432,26 +450,10 @@ addIdSpecialisations id spec_stuff
 %************************************************************************
 
 \begin{code}
-data ProtoCoreRule 
-  = ProtoCoreRule 
-       Bool            -- True <=> this rule was defined in this module,
-       Id              -- What Id is it for
-       CoreRule        -- The rule itself
-       
-
-pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule
-
-lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+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
-
-orphanRule :: ProtoCoreRule -> Bool
--- An "orphan rule" is one that is defined in this 
--- module, but of ran *imported* function.  We need
--- to track these separately when generating the interface file
-orphanRule (ProtoCoreRule local fn _)
-  = local && not (isLocallyDefined fn)
 \end{code}
 
 
@@ -462,58 +464,49 @@ orphanRule (ProtoCoreRule local fn _)
 %************************************************************************
 
 \begin{code}
-type RuleBase = (IdSet,                -- Imported Ids that have rules attached
-                IdSet)         -- Ids (whether local or imported) mentioned on 
+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
 
--- 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
+       -- This representation is a bit cute, and I wonder if we should
+       -- change it to use (IdEnv CoreRule) which seems a bit more natural
 
-prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
-prepareRuleBase binds rules
-  = (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs))
-  where
-    (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) rules
-    imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
-
-       -- rule_fvs is the set of all variables mentioned in rules
-    rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids
-
-       -- Attach the rules for each locally-defined Id to that Id.
-       --      - This makes the rules easier to look up
-       --      - It means that transformation rules and specialisations for
-       --        locally defined Ids are handled uniformly
-       --      - It keeps alive things that are referred to only from a rule
-       --        (the occurrence analyser knows about rules attached to Ids)
-       --      - It makes sure that, when we apply a rule, the free vars
-       --        of the RHS are more likely to be in scope
-       --
-       -- The LHS and RHS Ids are marked 'no-discard'. 
-       -- This means that the binding won't be discarded EVEN if the binding
-       -- ends up being trivial (v = w) -- the simplifier would usually just 
-       -- substitute w for v throughout, but we don't apply the substitution to
-       -- the rules (maybe we should?), so this substitution would make the rule
-       -- bogus.
-    zap_bind (NonRec b r) = NonRec (zap_bndr b) r
-    zap_bind (Rec prs)    = Rec [(zap_bndr b, r) | (b,r) <- prs]
-
-    zap_bndr bndr = case lookupVarSet rule_ids bndr of
-                         Just bndr'                           -> setIdNoDiscard bndr'
-                         Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
-                                 | otherwise                  -> bndr
-                 
-add_rule (ProtoCoreRule _ id rule)
-        (rule_id_set, rule_fvs)
-  = (rule_id_set `extendVarSet` new_id,
-     rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
+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)
+
+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)
+  = RuleBase (extendVarSet rule_ids new_id)
+            (rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
   where
-    new_id = case lookupVarSet rule_id_set id of
-               Just id' -> addRuleToId id' rule
-               Nothing  -> addRuleToId id  rule
-    lhs_fvs = ruleSomeLhsFreeVars isId rule
-       -- Find *all* the free Ids of the LHS, not just
+    new_id = setIdSpecialisation id (addRule old_rules id 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!!
 
-addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule)
+pprRuleBase :: RuleBase -> SDoc
+pprRuleBase (RuleBase rules _) = vcat [ pprCoreRule (ppr id) rs
+                                     | id <- varSetElems rules,
+                                       rs <- rulesRules $ idSpecialisation id ]
 \end{code}
-