Occurrence analyser takes account of the phase when handing RULES

See Note [Finding rule RHS free vars]

This should make Roman happy.

diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index 90d7619..24af9e2 100644 (file)
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -28,7 +28,7 @@ module CoreFVs (
         -- * Free variables of Rules, Vars and Ids
         varTypeTyVars, varTypeTcTyVars, 
        idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
         -- * Free variables of Rules, Vars and Ids
         varTypeTyVars, varTypeTcTyVars, 
        idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,

-       idRuleVars, idRuleRhsVars,
+        idRuleVars, idRuleRhsVars, stableUnfoldingVars,

        ruleRhsFreeVars, rulesFreeVars,
        ruleLhsFreeNames, ruleLhsFreeIds, 
 
        ruleRhsFreeVars, rulesFreeVars,
        ruleLhsFreeNames, ruleLhsFreeIds, 
 

@@ -51,6 +51,7 @@ import VarSet
 import Var
 import TcType
 import Util
 import Var
 import TcType
 import Util

+import BasicTypes( Activation )

 import Outputable
 \end{code}
 
 import Outputable
 \end{code}
 

@@ -285,6 +286,20 @@ ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args
   where
     fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
 
   where
     fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
 

+idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
+-- Just the variables free on the *rhs* of a rule
+idRuleRhsVars is_active id 
+  = foldr (unionVarSet . get_fvs) emptyVarSet (idCoreRules id)
+  where
+    get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
+                  , ru_rhs = rhs, ru_act = act })
+      | is_active act
+           -- See Note [Finding rule RHS free vars] in OccAnal.lhs
+      = delFromUFM fvs fn       -- Note [Rule free var hack]
+      where
+        fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
+    get_fvs _ = noFVs
+

 -- | Those variables free in the right hand side of several rules
 rulesFreeVars :: [CoreRule] -> VarSet
 rulesFreeVars rules = foldr (unionVarSet . ruleFreeVars) emptyVarSet rules
 -- | Those variables free in the right hand side of several rules
 rulesFreeVars :: [CoreRule] -> VarSet
 rulesFreeVars rules = foldr (unionVarSet . ruleFreeVars) emptyVarSet rules

@@ -406,26 +421,19 @@ idRuleAndUnfoldingVars id = ASSERT( isId id)
 idRuleVars ::Id -> VarSet  -- Does *not* include CoreUnfolding vars
 idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
 
 idRuleVars ::Id -> VarSet  -- Does *not* include CoreUnfolding vars
 idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
 

-idRuleRhsVars :: Id -> VarSet   -- Does *not* include the CoreUnfolding vars
--- Just the variables free on the *rhs* of a rule
--- See Note [Choosing loop breakers] in Simplify.lhs
-idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) 
-                        emptyVarSet
-                        (idCoreRules id)
-

 idUnfoldingVars :: Id -> VarSet
 -- Produce free vars for an unfolding, but NOT for an ordinary
 -- (non-inline) unfolding, since it is a dup of the rhs
 -- and we'll get exponential behaviour if we look at both unf and rhs!
 -- But do look at the *real* unfolding, even for loop breakers, else
 -- we might get out-of-scope variables
 idUnfoldingVars :: Id -> VarSet
 -- Produce free vars for an unfolding, but NOT for an ordinary
 -- (non-inline) unfolding, since it is a dup of the rhs
 -- and we'll get exponential behaviour if we look at both unf and rhs!
 -- But do look at the *real* unfolding, even for loop breakers, else
 -- we might get out-of-scope variables

-idUnfoldingVars id
-  = case realIdUnfolding id of
-      CoreUnfolding { uf_tmpl = rhs, uf_src = src }
-                            | isStableSource src
-                            -> exprFreeVars rhs
-      DFunUnfolding _ _ args -> exprsFreeVars args
-      _                      -> emptyVarSet
+idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id)
+
+stableUnfoldingVars :: Unfolding -> VarSet
+stableUnfoldingVars (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
+  | isStableSource src                       = exprFreeVars rhs
+stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars args
+stableUnfoldingVars _                        = emptyVarSet

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index e2c07af..18b12a6 100644 (file)
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -699,7 +699,8 @@ simpleOptPgm dflags binds rules
 
        ; return (reverse binds', substRulesForImportedIds subst' rules) }
   where
 
        ; return (reverse binds', substRulesForImportedIds subst' rules) }
   where

-    occ_anald_binds  = occurAnalysePgm binds rules
+    occ_anald_binds  = occurAnalysePgm Nothing {- No rules active -}
+                                       rules binds

     (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
                        
     do_one (subst, binds') bind 
     (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
                        
     do_one (subst, binds') bind 

diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index d97368a..ba8b5cb 100644 (file)
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -29,7 +29,7 @@ import Name           ( Name, localiseName )
 import BasicTypes
 import VarSet
 import VarEnv
 import BasicTypes
 import VarSet
 import VarEnv

-import Var             ( Var, varUnique )
+import Var              ( varUnique )

 import Maybes           ( orElse )
 import Digraph          ( SCC(..), stronglyConnCompFromEdgedVerticesR )
 import PrelNames        ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
 import Maybes           ( orElse )
 import Digraph          ( SCC(..), stronglyConnCompFromEdgedVerticesR )
 import PrelNames        ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )

@@ -52,11 +52,12 @@ import Data.List
 Here's the externally-callable interface:
 
 \begin{code}
 Here's the externally-callable interface:
 
 \begin{code}

-occurAnalysePgm :: [CoreBind] -> [CoreRule] -> [CoreBind]
-occurAnalysePgm binds rules
-  = snd (go (initOccEnv rules) binds)
+occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule]
+                -> [CoreBind] -> [CoreBind]
+occurAnalysePgm active_rule imp_rules binds
+  = snd (go (initOccEnv active_rule imp_rules) binds)

   where
   where

-    initial_uds = addIdOccs emptyDetails (rulesFreeVars rules)
+    initial_uds = addIdOccs emptyDetails (rulesFreeVars imp_rules)

     -- The RULES keep things alive!
 
     go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
     -- The RULES keep things alive!
 
     go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])

@@ -70,7 +71,11 @@ occurAnalysePgm binds rules
 
 occurAnalyseExpr :: CoreExpr -> CoreExpr
         -- Do occurrence analysis, and discard occurence info returned
 
 occurAnalyseExpr :: CoreExpr -> CoreExpr
         -- Do occurrence analysis, and discard occurence info returned

-occurAnalyseExpr expr = snd (occAnal (initOccEnv []) expr)
+occurAnalyseExpr expr 
+  = snd (occAnal (initOccEnv all_active_rules []) expr)
+  where
+    -- To be conservative, we say that all inlines and rules are active
+    all_active_rules = Just (\_ -> True)

 \end{code}
 
 
 \end{code}
 
 

@@ -99,11 +104,13 @@ occAnalBind env _ (NonRec binder rhs) body_usage
   = (body_usage, [])
 
   | otherwise                   -- It's mentioned in the body
   = (body_usage, [])
 
   | otherwise                   -- It's mentioned in the body

-  = (body_usage' +++ addRuleUsage rhs_usage binder,     -- Note [Rules are extra RHSs]
-     [NonRec tagged_binder rhs'])
+  = (body_usage' +++ rhs_usage3, [NonRec tagged_binder rhs'])

   where
     (body_usage', tagged_binder) = tagBinder body_usage binder
   where
     (body_usage', tagged_binder) = tagBinder body_usage binder

-    (rhs_usage, rhs')            = occAnalRhs env tagged_binder rhs
+    (rhs_usage1, rhs')           = occAnalRhs env (idOccInfo tagged_binder) rhs
+    rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder)
+    rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder)
+       -- See Note [Rules are extra RHSs] and Note [Rule dependency info]

 \end{code}
 
 Note [Dead code]
 \end{code}
 
 Note [Dead code]

@@ -189,7 +196,7 @@ However things are made quite a bit more complicated by RULES.  Remember
     [Rules for recursive functions] in Simplify.lhs
 
     Hence, if
     [Rules for recursive functions] in Simplify.lhs
 
     Hence, if

-        f's RHS mentions g, and
+        f's RHS (or its INLINE template if it has one) mentions g, and

         g has a RULE that mentions h, and
         h has a RULE that mentions f
 
         g has a RULE that mentions h, and
         h has a RULE that mentions f
 

@@ -198,6 +205,7 @@ However things are made quite a bit more complicated by RULES.  Remember
     reachable by RULES from those starting points.  That is the whole
     reason for computing rule_fv_env in occAnalBind.  (Of course we
     only consider free vars that are also binders in this Rec group.)
     reachable by RULES from those starting points.  That is the whole
     reason for computing rule_fv_env in occAnalBind.  (Of course we
     only consider free vars that are also binders in this Rec group.)

+    See also Note [Finding rule RHS free vars]

 
     Note that when we compute this rule_fv_env, we only consider variables
     free in the *RHS* of the rule, in contrast to the way we build the
 
     Note that when we compute this rule_fv_env, we only consider variables
     free in the *RHS* of the rule, in contrast to the way we build the

@@ -221,7 +229,23 @@ However things are made quite a bit more complicated by RULES.  Remember
         rec_edges          for the Rec block analysis
         loop_breaker_edges for the loop breaker analysis
 
         rec_edges          for the Rec block analysis
         loop_breaker_edges for the loop breaker analysis
 

-
+  * Note [Finding rule RHS free vars]
+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    Consider this real example from Data Parallel Haskell
+        tagZero :: Array Int -> Array Tag
+        {-# INLINE [1] tagZeroes #-}
+        tagZero xs = pmap (\x -> fromBool (x==0)) xs
+
+        {-# RULES "tagZero" [~1] forall xs n.
+            pmap fromBool <blah blah> = tagZero xs #-}     
+    So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.
+    However, tagZero can only be inlined in phase 1 and later, while
+    the RULE is only active *before* phase 1.  So there's no problem.
+
+    To make this work, we look for the RHS free vars only for
+    *active* rules.  That's the reason for the is_active argument
+    to idRhsRuleVars, and the occ_rule_act field of the OccEnv.
+ 

   * Note [Weak loop breakers]
     ~~~~~~~~~~~~~~~~~~~~~~~~~
     There is a last nasty wrinkle.  Suppose we have
   * Note [Weak loop breakers]
     ~~~~~~~~~~~~~~~~~~~~~~~~~
     There is a last nasty wrinkle.  Suppose we have

@@ -234,7 +258,7 @@ However things are made quite a bit more complicated by RULES.  Remember
               ...more...
         }
 
               ...more...
         }
 

-    Remmber that we simplify the RULES before any RHS (see Note
+    Remember that we simplify the RULES before any RHS (see Note

     [Rules are visible in their own rec group] above).
 
     So we must *not* postInlineUnconditionally 'g', even though
     [Rules are visible in their own rec group] above).
 
     So we must *not* postInlineUnconditionally 'g', even though

@@ -259,7 +283,7 @@ However things are made quite a bit more complicated by RULES.  Remember
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~
     The VarSet in a SpecInfo is used for dependency analysis in the
     occurrence analyser.  We must track free vars in *both* lhs and rhs.  
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~
     The VarSet in a SpecInfo is used for dependency analysis in the
     occurrence analyser.  We must track free vars in *both* lhs and rhs.  

-    Hence use of idRuleVars, rather than idRuleRhsVars in addRuleUsage.  
+    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.

     Why both? Consider
         x = y
         RULE f x = 4
     Why both? Consider
         x = y
         RULE f x = 4

@@ -274,6 +298,35 @@ However things are made quite a bit more complicated by RULES.  Remember
     at the same time as the regular RHS of the function, so it should
     be treated *exactly* like an extra RHS.
 
     at the same time as the regular RHS of the function, so it should
     be treated *exactly* like an extra RHS.
 

+    There is a danger that we'll be sub-optimal if we see this
+         f = ...f...
+         [INLINE f = ..no f...]
+    where f is recursive, but the INLINE is not. This can just about
+    happen with a sufficiently odd set of rules; eg
+
+       foo :: Int -> Int
+       {-# INLINE [1] foo #-}
+       foo x = x+1
+
+       bar :: Int -> Int
+       {-# INLINE [1] bar #-}
+       bar x = foo x + 1
+
+       {-# RULES "foo" [~1] forall x. foo x = bar x #-}
+
+    Here the RULE makes bar recursive; but it's INLINE pragma remains
+    non-recursive. It's tempting to then say that 'bar' should not be
+    a loop breaker, but an attempt to do so goes wrong in two ways:
+       a) We may get
+             $df = ...$cfoo...
+             $cfoo = ...$df....
+             [INLINE $cfoo = ...no-$df...]
+          But we want $cfoo to depend on $df explicitly so that we
+          put the bindings in the right order to inline $df in $cfoo
+          and perhaps break the loop altogether.  (Maybe this
+       b)
+
+

 
 Example [eftInt]
 ~~~~~~~~~~~~~~~
 
 Example [eftInt]
 ~~~~~~~~~~~~~~~

@@ -311,7 +364,7 @@ This showed up when compiling Control.Concurrent.Chan.getChanContents.
 
 \begin{code}
 occAnalBind _ env (Rec pairs) body_usage
 
 \begin{code}
 occAnalBind _ env (Rec pairs) body_usage

-  = foldr occAnalRec (body_usage, []) sccs
+  = foldr (occAnalRec env) (body_usage, []) sccs

        -- For a recursive group, we 
        --      * occ-analyse all the RHSs
        --      * compute strongly-connected components
        -- For a recursive group, we 
        --      * occ-analyse all the RHSs
        --      * compute strongly-connected components

@@ -327,13 +380,21 @@ occAnalBind _ env (Rec pairs) body_usage
     rec_edges = {-# SCC "occAnalBind.assoc" #-}  map make_node pairs
     
     make_node (bndr, rhs)
     rec_edges = {-# SCC "occAnalBind.assoc" #-}  map make_node pairs
     
     make_node (bndr, rhs)

-       = (ND bndr rhs' all_rhs_usage rhs_fvs, varUnique bndr, out_edges)
+        = (details, varUnique bndr, keysUFM out_edges)

        where
        where

-         (rhs_usage, rhs') = occAnalRhs env bndr rhs
-         all_rhs_usage = addIdOccs rhs_usage rule_vars -- Note [Rules are extra RHSs]
-         rhs_fvs   = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
-         out_edges = keysUFM (rhs_fvs `unionVarSet` rule_vars)
-          rule_vars = idRuleVars bndr      -- See Note [Rule dependency info]
+          details = ND { nd_bndr = bndr, nd_rhs = rhs'
+                       , nd_uds = rhs_usage3, nd_inl = inl_fvs}
+
+          (rhs_usage1, rhs') = occAnalRhs env NoOccInfo rhs
+          rhs_usage2 = addIdOccs rhs_usage1 rule_fvs -- Note [Rules are extra RHSs]
+          rhs_usage3 = addIdOccs rhs_usage2 unf_fvs
+          unf        = realIdUnfolding bndr     -- Ignore any current loop-breaker flag
+          unf_fvs    = stableUnfoldingVars unf
+          rule_fvs   = idRuleVars bndr          -- See Note [Rule dependency info]
+
+          inl_fvs   = rhs_fvs `unionVarSet` unf_fvs
+          rhs_fvs   = intersectUFM_C (\b _ -> b) bndr_set rhs_usage1
+          out_edges = intersectUFM_C (\b _ -> b) bndr_set rhs_usage3

         -- (a -> b) means a mentions b
         -- Given the usage details (a UFM that gives occ info for each free var of
         -- the RHS) we can get the list of free vars -- or rather their Int keys --
         -- (a -> b) means a mentions b
         -- Given the usage details (a UFM that gives occ info for each free var of
         -- the RHS) we can get the list of free vars -- or rather their Int keys --

@@ -345,11 +406,13 @@ occAnalBind _ env (Rec pairs) body_usage
         -- consumed 10% of total runtime!
 
 -----------------------------
         -- consumed 10% of total runtime!
 
 -----------------------------

-occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind])
-                                -> (UsageDetails, [CoreBind])
+occAnalRec :: OccEnv -> SCC (Node Details)
+           -> (UsageDetails, [CoreBind])
+          -> (UsageDetails, [CoreBind])

 
        -- The NonRec case is just like a Let (NonRec ...) above
 
        -- The NonRec case is just like a Let (NonRec ...) above

-occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds)
+occAnalRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_usage}, _, _))
+             (body_usage, binds)

   | not (bndr `usedIn` body_usage) 
   = (body_usage, binds)
 
   | not (bndr `usedIn` body_usage) 
   = (body_usage, binds)
 

@@ -362,7 +425,7 @@ occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds)
 
        -- The Rec case is the interesting one
        -- See Note [Loop breaking]
 
        -- The Rec case is the interesting one
        -- See Note [Loop breaking]

-occAnalRec (CyclicSCC nodes) (body_usage, binds)
+occAnalRec env (CyclicSCC nodes) (body_usage, binds)

   | not (any (`usedIn` body_usage) bndrs)      -- NB: look at body_usage, not total_usage
   = (body_usage, binds)                                -- Dead code
 
   | not (any (`usedIn` body_usage) bndrs)      -- NB: look at body_usage, not total_usage
   = (body_usage, binds)                                -- Dead code
 

@@ -370,13 +433,15 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds)
   = (final_usage, Rec pairs : binds)
 
   where
   = (final_usage, Rec pairs : binds)
 
   where

-    bndrs    = [b | (ND b _ _ _, _, _) <- nodes]
+    bndrs    = [b | (ND { nd_bndr = b }, _, _) <- nodes]

     bndr_set = mkVarSet bndrs
     bndr_set = mkVarSet bndrs

+    non_boring bndr = isId bndr &&
+                      (isStableUnfolding (realIdUnfolding bndr) || idHasRules bndr)

 
        ----------------------------
        -- Tag the binders with their occurrence info
     total_usage = foldl add_usage body_usage nodes
 
        ----------------------------
        -- Tag the binders with their occurrence info
     total_usage = foldl add_usage body_usage nodes

-    add_usage usage_so_far (ND _ _ rhs_usage _, _, _) = usage_so_far +++ rhs_usage
+    add_usage usage_so_far (ND { nd_uds = rhs_usage }, _, _) = usage_so_far +++ rhs_usage

     (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
 
     tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
     (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
 
     tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)

@@ -385,8 +450,8 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds)
        --      saying "no preInlineUnconditionally" if it is used
        --      in any rule (lhs or rhs) of the recursive group
        --      See Note [Weak loop breakers]
        --      saying "no preInlineUnconditionally" if it is used
        --      in any rule (lhs or rhs) of the recursive group
        --      See Note [Weak loop breakers]

-    tag_node usage (ND bndr rhs rhs_usage rhs_fvs, k, ks)
-      = (usage `delVarEnv` bndr, (ND bndr2 rhs rhs_usage rhs_fvs, k, ks))
+    tag_node usage (details@ND { nd_bndr = bndr }, k, ks)
+      = (usage `delVarEnv` bndr, (details { nd_bndr = bndr2 }, k, ks))

       where
        bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
              | otherwise                      = bndr1
       where
        bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
              | otherwise                      = bndr1

@@ -396,26 +461,32 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds)
 
        ----------------------------
        -- Now reconstruct the cycle
 
        ----------------------------
        -- Now reconstruct the cycle

-    pairs | no_rules  = reOrderCycle 0 tagged_nodes []
-         | otherwise = foldr (reOrderRec 0) [] $
-                       stronglyConnCompFromEdgedVerticesR loop_breaker_edges
+    pairs | any non_boring bndrs
+          = foldr (reOrderRec 0) [] $
+            stronglyConnCompFromEdgedVerticesR loop_breaker_edges
+          | otherwise
+          = reOrderCycle 0 tagged_nodes []

 
        -- See Note [Choosing loop breakers] for loop_breaker_edges
     loop_breaker_edges = map mk_node tagged_nodes
 
        -- See Note [Choosing loop breakers] for loop_breaker_edges
     loop_breaker_edges = map mk_node tagged_nodes

-    mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
+    mk_node (details@(ND { nd_inl = inl_fvs }), k, _) = (details, k, new_ks)

        where
        where

-         new_ks = keysUFM (fst (extendFvs rule_fv_env rhs_fvs))
+          new_ks = keysUFM (fst (extendFvs rule_fv_env inl_fvs))

 
     ------------------------------------
     rule_fv_env :: IdEnv IdSet  -- Variables from this group mentioned in RHS of rules
                                 -- Domain is *subset* of bound vars (others have no rule fvs)
 
     ------------------------------------
     rule_fv_env :: IdEnv IdSet  -- Variables from this group mentioned in RHS of rules
                                 -- Domain is *subset* of bound vars (others have no rule fvs)

-    rule_fv_env   = transClosureFV init_rule_fvs 
-    no_rules      = null init_rule_fvs
-    init_rule_fvs = [(b, rule_fvs)
-                    | b <- bndrs
-                   , isId b
-                    , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
-                    , not (isEmptyVarSet rule_fvs)]
+    rule_fv_env = transClosureFV init_rule_fvs
+    init_rule_fvs
+      | Just is_active <- occ_rule_act env  -- See Note [Finding rule RHS free vars]
+      = [ (b, rule_fvs)
+        | b <- bndrs
+       , isId b
+        , let rule_fvs = idRuleRhsVars is_active b
+                         `intersectVarSet` bndr_set
+        , not (isEmptyVarSet rule_fvs)]
+      | otherwise 
+      = []

 \end{code}
 
 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
 \end{code}
 
 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic

@@ -455,39 +526,41 @@ Perhaps something cleverer would suffice.
 \begin{code}
 type Node details = (details, Unique, [Unique])        -- The Ints are gotten from the Unique,
                                                -- which is gotten from the Id.
 \begin{code}
 type Node details = (details, Unique, [Unique])        -- The Ints are gotten from the Unique,
                                                -- which is gotten from the Id.

-data Details = ND Id           -- Binder
-                 CoreExpr      -- RHS
+data Details
+  = ND { nd_bndr :: Id          -- Binder
+       , nd_rhs  :: CoreExpr    -- RHS

 
 

-                 UsageDetails  -- Full usage from RHS, 
-                                -- including *both* RULES *and* InlineRule unfolding
+       , nd_uds  :: UsageDetails  -- Usage from RHS,
+                                  -- including RULES and InlineRule unfolding

 
 

-                 IdSet         -- Other binders *from this Rec group* mentioned in
-                               --   * the  RHS
-                               --   * any InlineRule unfolding
-                               -- but *excluding* any RULES
+       , nd_inl  :: IdSet       -- Other binders *from this Rec group* mentioned in
+       }                        --   its InlineRule unfolding (if present)
+                                --   AND the  RHS
+                                -- but *excluding* any RULES
+                                -- This is the IdSet that may be used if the Id is inlined

 
 reOrderRec :: Int -> SCC (Node Details)
            -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
 -- Sorted into a plausible order.  Enough of the Ids have
 --      IAmALoopBreaker pragmas that there are no loops left.
 
 reOrderRec :: Int -> SCC (Node Details)
            -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
 -- Sorted into a plausible order.  Enough of the Ids have
 --      IAmALoopBreaker pragmas that there are no loops left.

-reOrderRec _ (AcyclicSCC (ND bndr rhs _ _, _, _)) pairs = (bndr, rhs) : pairs
-reOrderRec depth (CyclicSCC cycle)               pairs = reOrderCycle depth cycle pairs
+reOrderRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _))
+                                   pairs = (bndr, rhs) : pairs
+reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs

 
 reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
 reOrderCycle _ [] _
   = panic "reOrderCycle"
 
 reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
 reOrderCycle _ [] _
   = panic "reOrderCycle"

-reOrderCycle _ [bind] pairs    -- Common case of simple self-recursion
-  = (makeLoopBreaker False bndr, rhs) : pairs
-  where
-    (ND bndr rhs _ _, _, _) = bind
+reOrderCycle _ [(ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)] pairs
+  =    -- Common case of simple self-recursion
+    (makeLoopBreaker False bndr, rhs) : pairs

 
 reOrderCycle depth (bind : binds) pairs
   =     -- Choose a loop breaker, mark it no-inline,
         -- do SCC analysis on the rest, and recursively sort them out
 
 reOrderCycle depth (bind : binds) pairs
   =     -- Choose a loop breaker, mark it no-inline,
         -- do SCC analysis on the rest, and recursively sort them out

---    pprTrace "reOrderCycle" (ppr [b | (ND b _ _ _, _, _) <- bind:binds]) $
+--    pprTrace "reOrderCycle" (ppr [b | (ND { nd_bndr = b }, _, _) <- bind:binds]) $

     foldr (reOrderRec new_depth)
           ([ (makeLoopBreaker False bndr, rhs) 
     foldr (reOrderRec new_depth)
           ([ (makeLoopBreaker False bndr, rhs) 

-           | (ND bndr rhs _ _, _, _) <- chosen_binds] ++ pairs)
+           | (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) <- chosen_binds] ++ pairs)

          (stronglyConnCompFromEdgedVerticesR unchosen) 
   where
     (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds
          (stronglyConnCompFromEdgedVerticesR unchosen) 
   where
     (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds

@@ -519,13 +592,13 @@ reOrderCycle depth (bind : binds) pairs
           sc = score bind
 
     score :: Node Details -> Int        -- Higher score => less likely to be picked as loop breaker
           sc = score bind
 
     score :: Node Details -> Int        -- Higher score => less likely to be picked as loop breaker

-    score (ND bndr rhs _ _, _, _)
-        | not (isId bndr) = 100            -- A type or cercion varialbe is never a loop breaker
+    score (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)
+        | not (isId bndr) = 100            -- A type or cercion variable is never a loop breaker

 
         | isDFunId bndr = 9   -- Never choose a DFun as a loop breaker
                              -- Note [DFuns should not be loop breakers]
 
 
         | isDFunId bndr = 9   -- Never choose a DFun as a loop breaker
                              -- Note [DFuns should not be loop breakers]
 

-        | Just (inl_source, _) <- isStableUnfolding_maybe (idUnfolding bndr)
+        | Just inl_source <- isStableCoreUnfolding_maybe (idUnfolding bndr)

        = case inl_source of
             InlineWrapper {} -> 10  -- Note [INLINE pragmas]
             _other           ->  3  -- Data structures are more important than this
        = case inl_source of
             InlineWrapper {} -> 10  -- Note [INLINE pragmas]
             _other           ->  3  -- Data structures are more important than this

@@ -717,20 +790,17 @@ ToDo: try using the occurrence info for the inline'd binder.
 
 \begin{code}
 occAnalRhs :: OccEnv
 
 \begin{code}
 occAnalRhs :: OccEnv

-           -> Id -> CoreExpr    -- Binder and rhs
+           -> OccInfo -> CoreExpr    -- Binder and rhs

                                 -- For non-recs the binder is alrady tagged
                                 -- with occurrence info
            -> (UsageDetails, CoreExpr)
                                 -- For non-recs the binder is alrady tagged
                                 -- with occurrence info
            -> (UsageDetails, CoreExpr)

-             -- Returned usage details includes any INLINE rhs
-
-occAnalRhs env id rhs
-  | isId id   = (addIdOccs rhs_usage (idUnfoldingVars id), rhs')
-  | otherwise = (rhs_usage, rhs')
-       -- Include occurrences for the "extra RHS" from a CoreUnfolding
+              -- Returned usage details covers only the RHS,
+              -- and *not* the RULE or INLINE template for the Id
+occAnalRhs env occ rhs
+  = occAnal ctxt rhs

   where
   where

-    (rhs_usage, rhs') = occAnal ctxt rhs
-    ctxt | certainly_inline id = env
-         | otherwise           = rhsCtxt env
+    ctxt | certainly_inline = env
+         | otherwise        = rhsCtxt env

         -- Note that we generally use an rhsCtxt.  This tells the occ anal n
         -- that it's looking at an RHS, which has an effect in occAnalApp
         --
         -- Note that we generally use an rhsCtxt.  This tells the occ anal n
         -- that it's looking at an RHS, which has an effect in occAnalApp
         --

@@ -746,21 +816,11 @@ occAnalRhs env id rhs
         -- Result: multiple simplifier iterations.  Sigh.
         -- Crude solution: use rhsCtxt for things that occur just once...
 
         -- Result: multiple simplifier iterations.  Sigh.
         -- Crude solution: use rhsCtxt for things that occur just once...
 

-    certainly_inline id = case idOccInfo id of
+    certainly_inline = case occ of

                             OneOcc in_lam one_br _ -> not in_lam && one_br
                             _                      -> False
                             OneOcc in_lam one_br _ -> not in_lam && one_br
                             _                      -> False

-\end{code}

 
 
 
 

-
-\begin{code}
-addRuleUsage :: UsageDetails -> Var -> UsageDetails
--- Add the usage from RULES in Id to the usage
-addRuleUsage usage var 
-  | isId var  = addIdOccs usage (idRuleVars var)
-  | otherwise = usage
-        -- idRuleVars here: see Note [Rule dependency info]
-

 addIdOccs :: UsageDetails -> VarSet -> UsageDetails
 addIdOccs usage id_set = foldVarSet add usage id_set
   where
 addIdOccs :: UsageDetails -> VarSet -> UsageDetails
 addIdOccs usage id_set = foldVarSet add usage id_set
   where

@@ -1070,7 +1130,10 @@ data OccEnv
   = OccEnv { occ_encl            :: !OccEncl      -- Enclosing context information
           , occ_ctxt     :: !CtxtTy       -- Tells about linearity
           , occ_proxy    :: ProxyEnv
   = OccEnv { occ_encl            :: !OccEncl      -- Enclosing context information
           , occ_ctxt     :: !CtxtTy       -- Tells about linearity
           , occ_proxy    :: ProxyEnv

-           , occ_rule_fvs :: ImpRuleUsage }
+           , occ_rule_fvs :: ImpRuleUsage
+           , occ_rule_act :: Maybe (Activation -> Bool)        -- Nothing => Rules are inactive
+             -- See Note [Finding rule RHS free vars]
+    }

 
 
 -----------------------------
 
 
 -----------------------------

@@ -1102,11 +1165,14 @@ type CtxtTy = [Bool]
         --                      be applied many times; but when it is,
         --                      the CtxtTy inside applies
 
         --                      be applied many times; but when it is,
         --                      the CtxtTy inside applies
 

-initOccEnv :: [CoreRule] -> OccEnv
-initOccEnv rules = OccEnv { occ_encl  = OccVanilla
-                         , occ_ctxt  = []
-                         , occ_proxy = PE emptyVarEnv emptyVarSet
-                         , occ_rule_fvs = findImpRuleUsage rules }
+initOccEnv :: Maybe (Activation -> Bool) -> [CoreRule] 
+           -> OccEnv
+initOccEnv active_rule imp_rules
+  = OccEnv { occ_encl  = OccVanilla
+          , occ_ctxt  = []
+          , occ_proxy = PE emptyVarEnv emptyVarSet
+           , occ_rule_fvs = findImpRuleUsage active_rule imp_rules
+           , occ_rule_act = active_rule }

 
 vanillaCtxt :: OccEnv -> OccEnv
 vanillaCtxt env = env { occ_encl = OccVanilla, occ_ctxt = [] }
 
 vanillaCtxt :: OccEnv -> OccEnv
 vanillaCtxt env = env { occ_encl = OccVanilla, occ_ctxt = [] }

@@ -1176,11 +1242,12 @@ that occur on the RULE's RHS.  This mapping from imported Id to local Ids
 is held in occ_rule_fvs.
 
 \begin{code}
 is held in occ_rule_fvs.
 
 \begin{code}

-findImpRuleUsage :: [CoreRule] -> ImpRuleUsage
+findImpRuleUsage :: Maybe (Activation -> Bool) -> [CoreRule] -> ImpRuleUsage

 -- Find the *local* Ids that can be reached transitively,
 -- via local rules, from each *imported* Id.  
 -- Sigh: this function seems more complicated than it is really worth
 -- Find the *local* Ids that can be reached transitively,
 -- via local rules, from each *imported* Id.  
 -- Sigh: this function seems more complicated than it is really worth

-findImpRuleUsage rules
+findImpRuleUsage Nothing _ = emptyNameEnv
+findImpRuleUsage (Just is_active) rules

   = mkNameEnv [ (f, mapUFM (\_ -> NoOccInfo) ls)
               | f <- rule_names 
               , let ls = find_lcl_deps f
   = mkNameEnv [ (f, mapUFM (\_ -> NoOccInfo) ls)
               | f <- rule_names 
               , let ls = find_lcl_deps f

@@ -1193,8 +1260,11 @@ findImpRuleUsage rules
       -- (f,g) means imported Id 'g' appears in RHS of 
       --       rule for imported Id 'f', *or* does so transitively
     imp_deps = foldr add_imp emptyNameEnv rules
       -- (f,g) means imported Id 'g' appears in RHS of 
       --       rule for imported Id 'f', *or* does so transitively
     imp_deps = foldr add_imp emptyNameEnv rules

-    add_imp rule acc = extendNameEnv_C unionVarSet acc (ru_fn rule)
-                             (exprSomeFreeVars keep_imp (ru_rhs rule))
+    add_imp rule acc 
+      | is_active (ruleActivation rule)
+      = extendNameEnv_C unionVarSet acc (ru_fn rule)
+                        (exprSomeFreeVars keep_imp (ru_rhs rule))
+      | otherwise = acc

     keep_imp v = isId v && (idName v `elemNameSet` rule_name_set)
     full_imp_deps = transClosureFV (ufmToList imp_deps)
 
     keep_imp v = isId v && (idName v `elemNameSet` rule_name_set)
     full_imp_deps = transClosureFV (ufmToList imp_deps)
 

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 581ac41..b64de6e 100644 (file)
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -20,7 +20,7 @@ import OccurAnal      ( occurAnalysePgm, occurAnalyseExpr )
 import IdInfo
 import CoreUtils       ( coreBindsSize )
 import Simplify                ( simplTopBinds, simplExpr )
 import IdInfo
 import CoreUtils       ( coreBindsSize )
 import Simplify                ( simplTopBinds, simplExpr )

-import SimplUtils      ( simplEnvForGHCi )
+import SimplUtils      ( simplEnvForGHCi, activeRule )

 import SimplEnv
 import SimplMonad
 import CoreMonad
 import SimplEnv
 import SimplMonad
 import CoreMonad

@@ -307,7 +307,7 @@ simplifyPgmIO :: CoreToDo
              -> ModGuts
              -> IO (SimplCount, ModGuts)  -- New bindings
 
              -> ModGuts
              -> IO (SimplCount, ModGuts)  -- New bindings
 

-simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
+simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)

               hsc_env us hpt_rule_base 
               guts@(ModGuts { mg_binds = binds, mg_rules = rules
                             , mg_fam_inst_env = fam_inst_env })
               hsc_env us hpt_rule_base 
               guts@(ModGuts { mg_binds = binds, mg_rules = rules
                             , mg_fam_inst_env = fam_inst_env })

@@ -323,9 +323,11 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
        ; return (counts_out, guts')
     }
   where
        ; return (counts_out, guts')
     }
   where

-    dflags              = hsc_dflags hsc_env
-    dump_phase          = dumpSimplPhase dflags mode
-    sw_chkr     = isAmongSimpl switches
+    dflags      = hsc_dflags hsc_env
+    dump_phase  = dumpSimplPhase dflags mode
+    simpl_env   = mkSimplEnv mode
+    active_rule = activeRule dflags simpl_env
+

     do_iteration :: UniqSupply
                  -> Int                 -- Counts iterations
                 -> [SimplCount] -- Counts from earlier iterations, reversed
     do_iteration :: UniqSupply
                  -> Int                 -- Counts iterations
                 -> [SimplCount] -- Counts from earlier iterations, reversed

@@ -355,7 +357,8 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
       | let sz = coreBindsSize binds in sz == sz
       = do {
                -- Occurrence analysis
       | let sz = coreBindsSize binds in sz == sz
       = do {
                -- Occurrence analysis

-          let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
+          let { tagged_binds = {-# SCC "OccAnal" #-} 
+                     occurAnalysePgm active_rule rules binds } ;

           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                     (pprCoreBindings tagged_binds);
 
           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                     (pprCoreBindings tagged_binds);
 

@@ -368,7 +371,6 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
           eps <- hscEPS hsc_env ;
           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
                ; rule_base2 = extendRuleBaseList rule_base1 rules
           eps <- hscEPS hsc_env ;
           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
                ; rule_base2 = extendRuleBaseList rule_base1 rules

-               ; simpl_env  = mkSimplEnv sw_chkr mode

                ; simpl_binds = {-# SCC "SimplTopBinds" #-} 
                                simplTopBinds simpl_env tagged_binds
                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
                ; simpl_binds = {-# SCC "SimplTopBinds" #-} 
                                simplTopBinds simpl_env tagged_binds
                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;