put coqPassCoreToCore on the CoreM monad, greatly simplify Desugar.lhs

[ghc-hetmet.git] / compiler / simplCore / OccurAnal.lhs

diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index d97368a..06133d6 100644 (file)
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -19,17 +19,18 @@ module OccurAnal (
 
 import CoreSyn
 import CoreFVs
 
 import CoreSyn
 import CoreFVs

-import Type            ( tyVarsOfType )
-import CoreUtils        ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp )
-import Coercion                ( CoercionI(..), mkSymCoI )
+import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce )

 import Id
 import NameEnv
 import NameSet
 import Name            ( Name, localiseName )
 import BasicTypes
 import Id
 import NameEnv
 import NameSet
 import Name            ( Name, localiseName )
 import BasicTypes

+import Coercion
+

 import VarSet
 import VarEnv
 import VarSet
 import VarEnv

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

 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,12 +53,14 @@ 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] -> [CoreVect]
+                -> [CoreBind] -> [CoreBind]
+occurAnalysePgm active_rule imp_rules vects binds
+  = snd (go (initOccEnv active_rule imp_rules) binds)

   where
   where

-    initial_uds = addIdOccs emptyDetails (rulesFreeVars rules)
-    -- The RULES keep things alive!
+    initial_uds = addIdOccs emptyDetails 
+                            (rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects)
+    -- The RULES and VECTORISE declarations keep things alive!

 
     go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
     go _ []
 
     go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
     go _ []

@@ -70,7 +73,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}
 
 

@@ -92,18 +99,20 @@ occAnalBind :: OccEnv               -- The incoming OccEnv
                 [CoreBind])
 
 occAnalBind env _ (NonRec binder rhs) body_usage
                 [CoreBind])
 
 occAnalBind env _ (NonRec binder rhs) body_usage

-  | isTyCoVar binder                   -- A type let; we don't gather usage info
+  | isTyVar binder     -- A type let; we don't gather usage info

   = (body_usage, [NonRec binder rhs])
 
   | not (binder `usedIn` body_usage)    -- It's not mentioned
   = (body_usage, [])
 
   | otherwise                   -- It's mentioned in the body
   = (body_usage, [NonRec binder rhs])
 
   | not (binder `usedIn` body_usage)    -- It's not mentioned
   = (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 (Just 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 +198,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 +207,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 +231,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 +260,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 +285,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 +300,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 +366,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 +382,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)
-       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, varUnique bndr, keysUFM out_edges)
+        where
+          details = ND { nd_bndr = bndr, nd_rhs = rhs'
+                       , nd_uds = rhs_usage3, nd_inl = inl_fvs}
+
+          (rhs_usage1, rhs') = occAnalRhs env Nothing 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 +408,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 +427,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 +435,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 +452,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 +463,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 +528,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 +594,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,49 +792,27 @@ ToDo: try using the occurrence info for the inline'd binder.
 
 \begin{code}
 occAnalRhs :: OccEnv
 
 \begin{code}
 occAnalRhs :: OccEnv

-           -> Id -> CoreExpr    -- Binder and rhs
-                                -- For non-recs the binder is alrady tagged
-                                -- with occurrence info
+           -> Maybe Id -> CoreExpr    -- Binder and rhs
+                 -- Just b  => non-rec, and alrady tagged with occurrence info
+                 -- Nothing => Rec, no occ info

            -> (UsageDetails, CoreExpr)
            -> (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 mb_bndr rhs
+  = occAnal ctxt rhs

   where
   where

-    (rhs_usage, rhs') = occAnal ctxt rhs
-    ctxt | certainly_inline id = 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
-        --
-        -- But there's a problem.  Consider
-        --      x1 = a0 : []
-        --      x2 = a1 : x1
-        --      x3 = a2 : x2
-        --      g  = f x3
-        -- First time round, it looks as if x1 and x2 occur as an arg of a
-        -- let-bound constructor ==> give them a many-occurrence.
-        -- But then x3 is inlined (unconditionally as it happens) and
-        -- next time round, x2 will be, and the next time round x1 will be
-        -- Result: multiple simplifier iterations.  Sigh.
-        -- Crude solution: use rhsCtxt for things that occur just once...
-
-    certainly_inline id = case idOccInfo id of
-                            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]
+    -- See Note [Cascading inlines]
+    ctxt = case mb_bndr of
+             Just b | certainly_inline b -> env
+             _other                      -> rhsCtxt env
+
+    certainly_inline bndr  -- See Note [Cascading inlines]
+      = case idOccInfo bndr of
+          OneOcc in_lam one_br _ -> not in_lam && one_br && active && not_stable
+          _                      -> False
+      where
+        active     = isAlwaysActive (idInlineActivation bndr)
+        not_stable = not (isStableUnfolding (idUnfolding bndr))

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

@@ -773,6 +826,46 @@ addIdOccs usage id_set = foldVarSet add usage id_set
        --      (Same goes for INLINE.)
 \end{code}
 
        --      (Same goes for INLINE.)
 \end{code}
 

+Note [Cascading inlines]
+~~~~~~~~~~~~~~~~~~~~~~~~
+By default we use an rhsCtxt for the RHS of a binding.  This tells the
+occ anal n that it's looking at an RHS, which has an effect in
+occAnalApp.  In particular, for constructor applications, it makes
+the arguments appear to have NoOccInfo, so that we don't inline into
+them. Thus    x = f y
+              k = Just x
+we do not want to inline x.
+
+But there's a problem.  Consider
+     x1 = a0 : []
+     x2 = a1 : x1
+     x3 = a2 : x2
+     g  = f x3
+First time round, it looks as if x1 and x2 occur as an arg of a
+let-bound constructor ==> give them a many-occurrence.
+But then x3 is inlined (unconditionally as it happens) and
+next time round, x2 will be, and the next time round x1 will be
+Result: multiple simplifier iterations.  Sigh.
+
+So, when analysing the RHS of x3 we notice that x3 will itself
+definitely inline the next time round, and so we analyse x3's rhs in
+an ordinary context, not rhsCtxt.  Hence the "certainly_inline" stuff.
+
+Annoyingly, we have to approximiate SimplUtils.preInlineUnconditionally.
+If we say "yes" when preInlineUnconditionally says "no" the simplifier iterates
+indefinitely:
+        x = f y
+        k = Just x
+inline ==>
+        k = Just (f y)
+float ==>
+        x1 = f y
+        k = Just x1
+
+This is worse than the slow cascade, so we only want to say "certainly_inline"
+if it really is certain.  Look at the note with preInlineUnconditionally
+for the various clauses.
+

 Expressions
 ~~~~~~~~~~~
 \begin{code}
 Expressions
 ~~~~~~~~~~~
 \begin{code}

@@ -781,33 +874,27 @@ occAnal :: OccEnv
         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
             CoreExpr)
 
         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
             CoreExpr)
 

-occAnal _   (Type t)  = (emptyDetails, Type t)
-occAnal env (Var v)   = (mkOneOcc env v False, Var v)
+occAnal _   expr@(Type _) = (emptyDetails,        expr)
+occAnal _   expr@(Lit _)  = (emptyDetails,        expr)   
+occAnal env expr@(Var v)  = (mkOneOcc env v False, expr)

     -- At one stage, I gathered the idRuleVars for v here too,
     -- which in a way is the right thing to do.
     -- But that went wrong right after specialisation, when
     -- the *occurrences* of the overloaded function didn't have any
     -- rules in them, so the *specialised* versions looked as if they
     -- weren't used at all.
     -- At one stage, I gathered the idRuleVars for v here too,
     -- which in a way is the right thing to do.
     -- But that went wrong right after specialisation, when
     -- the *occurrences* of the overloaded function didn't have any
     -- rules in them, so the *specialised* versions looked as if they
     -- weren't used at all.

-\end{code}
-
-We regard variables that occur as constructor arguments as "dangerousToDup":

 
 

-\begin{verbatim}
-module A where
-f x = let y = expensive x in
-      let z = (True,y) in
-      (case z of {(p,q)->q}, case z of {(p,q)->q})
-\end{verbatim}
-
-We feel free to duplicate the WHNF (True,y), but that means
-that y may be duplicated thereby.
+occAnal _ (Coercion co) 
+  = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
+       -- See Note [Gather occurrences of coercion veriables]
+\end{code}

 
 

-If we aren't careful we duplicate the (expensive x) call!
-Constructors are rather like lambdas in this way.
+Note [Gather occurrences of coercion veriables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to gather info about what coercion variables appear, so that
+we can sort them into the right place when doing dependency analysis.

 
 \begin{code}
 
 \begin{code}

-occAnal _   expr@(Lit _) = (emptyDetails, expr)

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -823,7 +910,10 @@ occAnal env (Note note body)
 
 occAnal env (Cast expr co)
   = case occAnal env expr of { (usage, expr') ->
 
 occAnal env (Cast expr co)
   = case occAnal env expr of { (usage, expr') ->

-      (markManyIf (isRhsEnv env) usage, Cast expr' co)
+    let usage1 = markManyIf (isRhsEnv env) usage
+        usage2 = addIdOccs usage1 (coVarsOfCo co)
+          -- See Note [Gather occurrences of coercion veriables]
+    in (usage2, Cast expr' co)

         -- If we see let x = y `cast` co
         -- then mark y as 'Many' so that we don't
         -- immediately inline y again.
         -- If we see let x = y `cast` co
         -- then mark y as 'Many' so that we don't
         -- immediately inline y again.

@@ -838,7 +928,7 @@ occAnal env app@(App _ _)
 --   (a) occurrences inside type lambdas only not marked as InsideLam
 --   (b) type variables not in environment
 
 --   (a) occurrences inside type lambdas only not marked as InsideLam
 --   (b) type variables not in environment
 

-occAnal env (Lam x body) | isTyCoVar x
+occAnal env (Lam x body) | isTyVar x

   = case occAnal env body of { (body_usage, body') ->
     (body_usage, Lam x body')
     }
   = case occAnal env body of { (body_usage, body') ->
     (body_usage, Lam x body')
     }

@@ -930,6 +1020,18 @@ occAnalArgs env args
 Applications are dealt with specially because we want
 the "build hack" to work.
 
 Applications are dealt with specially because we want
 the "build hack" to work.
 

+Note [Arguments of let-bound constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    f x = let y = expensive x in
+          let z = (True,y) in
+          (case z of {(p,q)->q}, case z of {(p,q)->q})
+We feel free to duplicate the WHNF (True,y), but that means
+that y may be duplicated thereby.
+
+If we aren't careful we duplicate the (expensive x) call!
+Constructors are rather like lambdas in this way.
+

 \begin{code}
 occAnalApp :: OccEnv
            -> (Expr CoreBndr, [Arg CoreBndr])
 \begin{code}
 occAnalApp :: OccEnv
            -> (Expr CoreBndr, [Arg CoreBndr])

@@ -945,6 +1047,7 @@ occAnalApp env (Var fun, args)
          -- arguments are just variables, or trivial expressions.
          --
          -- This is the *whole point* of the isRhsEnv predicate
          -- arguments are just variables, or trivial expressions.
          --
          -- This is the *whole point* of the isRhsEnv predicate

+         -- See Note [Arguments of let-bound constructors]

     in
     (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
   where
     in
     (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
   where

@@ -1055,7 +1158,7 @@ wrapProxy (bndr, rhs_var, co) (body_usg, body)
   where
     (body_usg', tagged_bndr) = tagBinder body_usg bndr
     rhs_usg = unitVarEnv rhs_var NoOccInfo     -- We don't need exact info
   where
     (body_usg', tagged_bndr) = tagBinder body_usg bndr
     rhs_usg = unitVarEnv rhs_var NoOccInfo     -- We don't need exact info

-    rhs = mkCoerceI co (Var rhs_var)
+    rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]

 \end{code}
 
 
 \end{code}
 
 

@@ -1070,7 +1173,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 +1208,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 +1285,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 +1303,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)
 

@@ -1251,9 +1364,11 @@ extendFvs env s
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-data ProxyEnv 
-   = PE (IdEnv (Id, [(Id,CoercionI)])) VarSet
-       -- Main env, and its free variables (of both range and domain)
+data ProxyEnv  -- See Note [ProxyEnv]
+   = PE (IdEnv -- Domain = scrutinee variables
+           (Id,                  -- The scrutinee variable again
+            [(Id,Coercion)]))   -- The case binders that it maps to
+        VarSet -- Free variables of both range and domain

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

@@ -1396,6 +1511,17 @@ From this we want to extract the bindings
 Notice that later bindings may mention earlier ones, and that
 we need to go "both ways".
 
 Notice that later bindings may mention earlier ones, and that
 we need to go "both ways".
 

+Note [Zap case binders in proxy bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+From the original
+     case x of cb(dead) { p -> ...x... }
+we will get
+     case x of cb(live) { p -> let x = cb in ...x... }
+
+Core Lint never expects to find an *occurence* of an Id marked
+as Dead, so we must zap the OccInfo on cb before making the 
+binding x = cb.  See Trac #5028.
+

 Historical note [no-case-of-case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We *used* to suppress the binder-swap in case expressions when 
 Historical note [no-case-of-case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We *used* to suppress the binder-swap in case expressions when 

@@ -1458,7 +1584,7 @@ binder-swap unconditionally and still get occurrence analysis
 information right.
 
 \begin{code}
 information right.
 
 \begin{code}

-extendProxyEnv :: ProxyEnv -> Id -> CoercionI -> Id -> ProxyEnv
+extendProxyEnv :: ProxyEnv -> Id -> Coercion -> Id -> ProxyEnv

 -- (extendPE x co y) typically arises from 
 --               case (x |> co) of y { ... }
 -- It extends the proxy env with the binding 
 -- (extendPE x co y) typically arises from 
 --               case (x |> co) of y { ... }
 -- It extends the proxy env with the binding 

@@ -1471,7 +1597,7 @@ extendProxyEnv pe scrut co case_bndr
     env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
     single cb_co = (scrut1, [cb_co]) 
     add cb_co (x, cb_cos) = (x, cb_co:cb_cos)
     env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
     single cb_co = (scrut1, [cb_co]) 
     add cb_co (x, cb_cos) = (x, cb_co:cb_cos)

-    fvs2 = fvs1 `unionVarSet`  freeVarsCoI co
+    fvs2 = fvs1 `unionVarSet`  tyCoVarsOfCo co

                `extendVarSet` case_bndr
                `extendVarSet` scrut1
 
                `extendVarSet` case_bndr
                `extendVarSet` scrut1
 

@@ -1479,10 +1605,11 @@ extendProxyEnv pe scrut co case_bndr
        -- Localise the scrut_var before shadowing it; we're making a 
        -- new binding for it, and it might have an External Name, or
        -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
        -- Localise the scrut_var before shadowing it; we're making a 
        -- new binding for it, and it might have an External Name, or
        -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]

-       -- Also we don't want any INLILNE or NOINLINE pragmas!
+       -- Also we don't want any INLINE or NOINLINE pragmas!

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

-type ProxyBind = (Id, Id, CoercionI)
+type ProxyBind = (Id, Id, Coercion)
+     -- (scrut variable, case-binder variable, coercion)

 
 getProxies :: OccEnv -> Id -> Bag ProxyBind
 -- Return a bunch of bindings [...(xi,ei)...] 
 
 getProxies :: OccEnv -> Id -> Bag ProxyBind
 -- Return a bunch of bindings [...(xi,ei)...] 

@@ -1492,7 +1619,7 @@ getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr
   = -- pprTrace "wrapProxies" (ppr case_bndr) $
     go_fwd case_bndr
   where
   = -- pprTrace "wrapProxies" (ppr case_bndr) $
     go_fwd case_bndr
   where

-    fwd_pe :: IdEnv (Id, CoercionI)
+    fwd_pe :: IdEnv (Id, Coercion)

     fwd_pe = foldVarEnv add1 emptyVarEnv pe
            where
              add1 (x,ycos) env = foldr (add2 x) env ycos
     fwd_pe = foldVarEnv add1 emptyVarEnv pe
            where
              add1 (x,ycos) env = foldr (add2 x) env ycos

@@ -1506,23 +1633,23 @@ getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr
 
     go_fwd' case_bndr
         | Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr
 
     go_fwd' case_bndr
         | Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr

-        = unitBag (scrut,  case_bndr, mkSymCoI co)
+        = unitBag (scrut,  case_bndr, mkSymCo co)

          `unionBags` go_fwd scrut
           `unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut
                                        , cb /= case_bndr]
         | otherwise 
         = emptyBag
 
          `unionBags` go_fwd scrut
           `unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut
                                        , cb /= case_bndr]
         | otherwise 
         = emptyBag
 

-    lookup_bwd :: Id -> [(Id, CoercionI)]
+    lookup_bwd :: Id -> [(Id, Coercion)]

        -- Return case_bndrs that are connected to scrut 
     lookup_bwd scrut = case lookupVarEnv pe scrut of
                          Nothing          -> []
                          Just (_, cb_cos) -> cb_cos
 
        -- Return case_bndrs that are connected to scrut 
     lookup_bwd scrut = case lookupVarEnv pe scrut of
                          Nothing          -> []
                          Just (_, cb_cos) -> cb_cos
 

-    go_bwd :: Id -> [(Id, CoercionI)] -> Bag ProxyBind
+    go_bwd :: Id -> [(Id, Coercion)] -> Bag ProxyBind

     go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos
 
     go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos
 

-    go_bwd1 :: Id -> (Id, CoercionI) -> Bag ProxyBind
+    go_bwd1 :: Id -> (Id, Coercion) -> Bag ProxyBind

     go_bwd1 scrut (case_bndr, co) 
        = -- pprTrace "go_bwd1" (ppr case_bndr) $
          unitBag (case_bndr, scrut, co)
     go_bwd1 scrut (case_bndr, co) 
        = -- pprTrace "go_bwd1" (ppr case_bndr) $
          unitBag (case_bndr, scrut, co)

@@ -1537,9 +1664,9 @@ mkAltEnv env scrut cb
   where
     pe  = occ_proxy env
     pe' = case scrut of
   where
     pe  = occ_proxy env
     pe' = case scrut of

-             Var v           -> extendProxyEnv pe v (IdCo (idType v)) cb
-             Cast (Var v) co -> extendProxyEnv pe v (ACo co)          cb
-            _other          -> trimProxyEnv pe [cb]
+             Var v           -> extendProxyEnv pe v (mkReflCo (idType v)) cb
+             Cast (Var v) co -> extendProxyEnv pe v co                    cb
+             _other          -> trimProxyEnv pe [cb]

 
 -----------
 trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv
 
 -----------
 trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv

@@ -1560,12 +1687,7 @@ trimProxyEnv (PE pe fvs) bndrs
     trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, [])
                         | otherwise = (scrut, filterOut discard cb_cos)
     discard (cb,co) = bndr_set `intersectsVarSet` 
     trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, [])
                         | otherwise = (scrut, filterOut discard cb_cos)
     discard (cb,co) = bndr_set `intersectsVarSet` 

-                      extendVarSet (freeVarsCoI co) cb
-                             
------------
-freeVarsCoI :: CoercionI -> VarSet
-freeVarsCoI (IdCo t) = tyVarsOfType t
-freeVarsCoI (ACo co) = tyVarsOfType co
+                      extendVarSet (tyCoVarsOfCo co) cb

 \end{code}
 
 
 \end{code}
 
 

@@ -1632,7 +1754,7 @@ tagBinder usage binder
 
 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
 setBinderOcc usage bndr
 
 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
 setBinderOcc usage bndr

-  | isTyCoVar bndr    = bndr
+  | isTyVar bndr      = bndr

   | isExportedId bndr = case idOccInfo bndr of
                           NoOccInfo -> bndr
                           _         -> setIdOccInfo bndr NoOccInfo
   | isExportedId bndr = case idOccInfo bndr of
                           NoOccInfo -> bndr
                           _         -> setIdOccInfo bndr NoOccInfo