Fix three problems with occurrence analysis on case alternatives.

Summary:
  1. Respect condition (a) in Note [Binder swap]
  2. Respect condition (b) in Note [Binder swap]
  3. Return usage of any coercion variables in binder swap

Fixes T9440

Test Plan: See #9440

Reviewers: simonpj, austin

Reviewed By: simonpj, austin

Subscribers: simonpj, simonmar, relrod, ezyang, carter

Differential Revision: https://phabricator.haskell.org/D156

GHC Trac Issues: #9440

1 files changed, 32 insertions, 21 deletions

diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index c9323359c5..42a6167f6f 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -1172,10 +1172,10 @@ occAnal env expr@(Var v)  = (mkOneOcc env v False, expr)
 
 occAnal _ (Coercion co)
   = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
-        -- See Note [Gather occurrences of coercion veriables]
+        -- See Note [Gather occurrences of coercion variables]
 \end{code}
 
-Note [Gather occurrences of coercion veriables]
+Note [Gather occurrences of coercion variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We need to gather info about what coercion variables appear, so that
 we can sort them into the right place when doing dependency analysis.
@@ -1269,7 +1269,7 @@ occAnal env (Case scrut bndr ty alts)
           Just _  -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo)
 
     alt_env = mkAltEnv env scrut bndr
-    occ_anal_alt = occAnalAlt alt_env bndr
+    occ_anal_alt = occAnalAlt alt_env
 
     occ_anal_scrut (Var v) (alt1 : other_alts)
         | not (null other_alts) || not (isDefaultAlt alt1)
@@ -1404,30 +1404,41 @@ scrutinised y).
 
 \begin{code}
 occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr))
-           -> CoreBndr
            -> CoreAlt
            -> (UsageDetails, Alt IdWithOccInfo)
-occAnalAlt (env, scrut_bind) case_bndr (con, bndrs, rhs)
+occAnalAlt (env, scrut_bind) (con, bndrs, rhs)
   = case occAnal env rhs of { (rhs_usage1, rhs1) ->
     let
-        (rhs_usage2, rhs2) =
-          wrapProxy (occ_binder_swap env) scrut_bind case_bndr rhs_usage1 rhs1 
-        (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage2 bndrs
-        bndrs' = tagged_bndrs      -- See Note [Binders in case alternatives]
+        (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs
+                                  -- See Note [Binders in case alternatives]
+        (alt_usg', rhs2) =
+          wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1
     in
-    (alt_usg, (con, bndrs', rhs2)) }
-
-wrapProxy :: Bool -> Maybe (Id, CoreExpr) -> Id -> UsageDetails -> CoreExpr -> (UsageDetails, CoreExpr)
-wrapProxy enable_binder_swap (Just (scrut_var, rhs)) case_bndr body_usg body
-  | enable_binder_swap,
-    scrut_var `usedIn` body_usg
-  = ( body_usg' +++ unitVarEnv case_bndr NoOccInfo
-    , Let (NonRec tagged_scrut_var rhs) body )
+    (alt_usg', (con, tagged_bndrs, rhs2)) }
+
+wrapAltRHS :: OccEnv
+           -> Maybe (Id, CoreExpr)      -- proxy mapping generated by mkAltEnv
+           -> UsageDetails              -- usage for entire alt (p -> rhs)
+           -> [Var]                     -- alt binders
+           -> CoreExpr                  -- alt RHS
+           -> (UsageDetails, CoreExpr)
+wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs
+  | occ_binder_swap env
+  , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this
+                               -- handles condition (a) in Note [Binder swap]
+  , not captured               -- See condition (b) in Note [Binder swap]
+  = ( alt_usg' +++ let_rhs_usg
+    , Let (NonRec tagged_scrut_var let_rhs') alt_rhs )
   where
-    (body_usg', tagged_scrut_var) = tagBinder body_usg scrut_var
-    
-wrapProxy _ _ _ body_usg body 
-  = (body_usg, body)
+    captured = any (`usedIn` let_rhs_usg) bndrs
+    -- The rhs of the let may include coercion variables
+    -- if the scrutinee was a cast, so we must gather their
+    -- usage. See Note [Gather occurrences of coercion variables]
+    (let_rhs_usg, let_rhs') = occAnal env let_rhs
+    (alt_usg', tagged_scrut_var) = tagBinder alt_usg scrut_var
+
+wrapAltRHS _ _ alt_usg _ alt_rhs
+  = (alt_usg, alt_rhs)
 \end{code}