Improve Simplifier and SpecConstr behaviour

Trac #4908 identified a case where SpecConstr wasn't "seeing" a
specialisation it should easily get.  The solution was simple: see
Note [Add scrutinee to ValueEnv too] in SpecConstr.

Then it turned out that there was an exactly analogous infelicity in
the mighty Simplifer too; see Note [Add unfolding for scrutinee] in
Simplify. This fix is good for Simplify even in the absence of the
SpecConstr change.  (It arose when I moved the binder- swap stuff to
OccAnall, not realising that it *remains* valuable to record info
about the scrutinee of a case expression.  The Note says why.

Together these two changes are unconditionally good.  Better
simplification, better specialisation. Thank you Max.

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 6fe24df..6794e19 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -38,7 +38,7 @@ import CostCentre       ( currentCCS, pushCCisNop )
 import TysPrim          ( realWorldStatePrimTy )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils      ( foldlM, mapAccumLM )
 import TysPrim          ( realWorldStatePrimTy )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils      ( foldlM, mapAccumLM )

-import Maybes           ( orElse )
+import Maybes           ( orElse, isNothing )

 import Data.List        ( mapAccumL )
 import Outputable
 import FastString
 import Data.List        ( mapAccumL )
 import Outputable
 import FastString

@@ -1682,16 +1682,6 @@ the case binder is guaranteed dead.
 In practice, the scrutinee is almost always a variable, so we pretty
 much always zap the OccInfo of the binders.  It doesn't matter much though.
 
 In practice, the scrutinee is almost always a variable, so we pretty
 much always zap the OccInfo of the binders.  It doesn't matter much though.
 

-
-Note [Case of cast]
-~~~~~~~~~~~~~~~~~~~
-Consider        case (v `cast` co) of x { I# y ->
-                ... (case (v `cast` co) of {...}) ...
-We'd like to eliminate the inner case.  We can get this neatly by
-arranging that inside the outer case we add the unfolding
-        v |-> x `cast` (sym co)
-to v.  Then we should inline v at the inner case, cancel the casts, and away we go
-

 Note [Improving seq]
 ~~~~~~~~~~~~~~~~~~~
 Consider
 Note [Improving seq]
 ~~~~~~~~~~~~~~~~~~~
 Consider

@@ -1708,7 +1698,7 @@ where x::F Int.  Then we'd like to rewrite (F Int) to Int, getting
 
 so that 'rhs' can take advantage of the form of x'.  
 
 
 so that 'rhs' can take advantage of the form of x'.  
 

-Notice that Note [Case of cast] may then apply to the result. 
+Notice that Note [Case of cast] (in OccurAnal) may then apply to the result. 

 
 Nota Bene: We only do the [Improving seq] transformation if the 
 case binder 'x' is actually used in the rhs; that is, if the case 
 
 Nota Bene: We only do the [Improving seq] transformation if the 
 case binder 'x' is actually used in the rhs; that is, if the case 

@@ -1765,7 +1755,9 @@ simplAlts env scrut case_bndr alts cont'
 
         ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
 
 
         ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
 

-        ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts
+       ; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing }
+        ; alts' <- mapM (simplAlt alt_env' mb_var_scrut
+                             imposs_deflt_cons case_bndr' cont') in_alts

         ; return (scrut', case_bndr', alts') }
 
 
         ; return (scrut', case_bndr', alts') }
 
 

@@ -1788,27 +1780,30 @@ improveSeq _ env scrut _ case_bndr1 _
 
 ------------------------------------
 simplAlt :: SimplEnv
 
 ------------------------------------
 simplAlt :: SimplEnv

-         -> [AltCon]    -- These constructors can't be present when
-                        -- matching the DEFAULT alternative
-         -> OutId       -- The case binder
+        -> Maybe OutId    -- Scrutinee
+         -> [AltCon]       -- These constructors can't be present when
+                           -- matching the DEFAULT alternative
+         -> OutId          -- The case binder

          -> SimplCont
          -> InAlt
          -> SimplM OutAlt
 
          -> SimplCont
          -> InAlt
          -> SimplM OutAlt
 

-simplAlt env imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
+simplAlt env scrut imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)

   = ASSERT( null bndrs )
   = ASSERT( null bndrs )

-    do  { let env' = addBinderOtherCon env case_bndr' imposs_deflt_cons
+    do  { let env' = addBinderUnfolding env scrut case_bndr' 
+                                        (mkOtherCon imposs_deflt_cons)

                 -- Record the constructors that the case-binder *can't* be.
         ; rhs' <- simplExprC env' rhs cont'
         ; return (DEFAULT, [], rhs') }
 
                 -- Record the constructors that the case-binder *can't* be.
         ; rhs' <- simplExprC env' rhs cont'
         ; return (DEFAULT, [], rhs') }
 

-simplAlt env _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
+simplAlt env scrut _ case_bndr' cont' (LitAlt lit, bndrs, rhs)

   = ASSERT( null bndrs )
   = ASSERT( null bndrs )

-    do  { let env' = addBinderUnfolding env case_bndr' (Lit lit)
+    do  { let env' = addBinderUnfolding env scrut case_bndr' 
+                                        (mkSimpleUnfolding (Lit lit))

         ; rhs' <- simplExprC env' rhs cont'
         ; return (LitAlt lit, [], rhs') }
 
         ; rhs' <- simplExprC env' rhs cont'
         ; return (LitAlt lit, [], rhs') }
 

-simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
+simplAlt env scrut _ case_bndr' cont' (DataAlt con, vs, rhs)

   = do  {       -- Deal with the pattern-bound variables
                 -- Mark the ones that are in ! positions in the
                 -- data constructor as certainly-evaluated.
   = do  {       -- Deal with the pattern-bound variables
                 -- Mark the ones that are in ! positions in the
                 -- data constructor as certainly-evaluated.

@@ -1819,8 +1814,8 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
                 -- Bind the case-binder to (con args)
         ; let inst_tys' = tyConAppArgs (idType case_bndr')
               con_args  = map Type inst_tys' ++ varsToCoreExprs vs'
                 -- Bind the case-binder to (con args)
         ; let inst_tys' = tyConAppArgs (idType case_bndr')
               con_args  = map Type inst_tys' ++ varsToCoreExprs vs'

-              env''     = addBinderUnfolding env' case_bndr'
-                                             (mkConApp con con_args)
+              unf       = mkSimpleUnfolding (mkConApp con con_args)
+              env''     = addBinderUnfolding env' scrut case_bndr' unf

 
         ; rhs' <- simplExprC env'' rhs cont'
         ; return (DataAlt con, vs', rhs') }
 
         ; rhs' <- simplExprC env'' rhs cont'
         ; return (DataAlt con, vs', rhs') }

@@ -1843,7 +1838,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
             | isMarkedStrict str = evald_v  : go vs' strs
             | otherwise          = zapped_v : go vs' strs
             where
             | isMarkedStrict str = evald_v  : go vs' strs
             | otherwise          = zapped_v : go vs' strs
             where

-              zapped_v = zap_occ_info v
+              zapped_v = zapBndrOccInfo keep_occ_info v

               evald_v  = zapped_v `setIdUnfolding` evaldUnfolding
           go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
 
               evald_v  = zapped_v `setIdUnfolding` evaldUnfolding
           go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs)
 

@@ -1855,25 +1850,49 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
         --        case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
         --   ==>  case e of t { (a,b) -> ...(a)... }
         -- Look, Ma, a is alive now.
         --        case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
         --   ==>  case e of t { (a,b) -> ...(a)... }
         -- Look, Ma, a is alive now.

-    zap_occ_info = zapCasePatIdOcc case_bndr'
+    keep_occ_info = isDeadBinder case_bndr' && isNothing scrut

 
 

-addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
-addBinderUnfolding env bndr rhs
-  = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs)
-
-addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
-addBinderOtherCon env bndr cons
-  = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons)
+addBinderUnfolding :: SimplEnv -> Maybe OutId -> Id -> Unfolding -> SimplEnv
+addBinderUnfolding env scrut bndr unf
+  = case scrut of
+       Just v -> modifyInScope env1 (v `setIdUnfolding` unf)
+       _      -> env1
+  where
+    env1 = modifyInScope env bndr_w_unf
+    bndr_w_unf = bndr `setIdUnfolding` unf

 
 

-zapCasePatIdOcc :: Id -> Id -> Id
+zapBndrOccInfo :: Bool -> Id -> Id

 -- Consider  case e of b { (a,b) -> ... }
 -- Then if we bind b to (a,b) in "...", and b is not dead,
 -- then we must zap the deadness info on a,b
 -- Consider  case e of b { (a,b) -> ... }
 -- Then if we bind b to (a,b) in "...", and b is not dead,
 -- then we must zap the deadness info on a,b

-zapCasePatIdOcc case_bndr
-  | isDeadBinder case_bndr = \ pat_id -> pat_id
-  | otherwise             = \ pat_id -> zapIdOccInfo pat_id
+zapBndrOccInfo keep_occ_info pat_id
+  | keep_occ_info = pat_id
+  | otherwise     = zapIdOccInfo pat_id

 \end{code}
 
 \end{code}
 

+Note [Add unfolding for scrutinee]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general it's unlikely that a variable scrutinee will appear 
+in the case alternatives   case x of { ...x unlikely to appear... }
+because the binder-swap in OccAnal has got rid of all such occcurrences
+See Note [Binder swap] in OccAnal.
+
+BUT it is still VERY IMPORTANT to add a suitable unfolding for a
+variable scrutinee, in simplAlt.  Here's why
+   case x of y
+     (a,b) -> case b of c
+                I# v -> ...(f y)...
+There is no occurrence of 'b' in the (...(f y)...).  But y gets
+the unfolding (a,b), and *that* mentions b.  If f has a RULE
+    RULE f (p, I# q) = ...
+we want that rule to match, so we must extend the in-scope env with a
+suitable unfolding for 'y'.  It's *essential* for rule matching; but
+it's also good for case-elimintation -- suppose that 'f' was inlined
+and did multi-level case analysis, then we'd solve it in one
+simplifier sweep instead of two.
+
+Exactly the same issue arises in SpecConstr; 
+see Note [Add scrutinee to ValueEnv too] in SpecConstr

 
 %************************************************************************
 %*                                                                      *
 
 %************************************************************************
 %*                                                                      *

@@ -1907,7 +1926,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
         ; env'' <- bind_case_bndr env'
         ; simplExprF env'' rhs cont }
   where
         ; env'' <- bind_case_bndr env'
         ; simplExprF env'' rhs cont }
   where

-    zap_occ = zapCasePatIdOcc bndr    -- bndr is an InId
+    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId

 
                   -- Ugh!
     bind_args env' [] _  = return env'
 
                   -- Ugh!
     bind_args env' [] _  = return env'

@@ -2040,7 +2059,7 @@ mkDupableCont env (Select _ case_bndr alts se cont)
 
         ; let alt_env = se `setInScope` env'
         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
 
         ; let alt_env = se `setInScope` env'
         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr

-        ; alts' <- mapM (simplAlt alt_env' [] case_bndr' dup_cont) alts
+        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts

         -- Safe to say that there are no handled-cons for the DEFAULT case
                 -- NB: simplBinder does not zap deadness occ-info, so
                 -- a dead case_bndr' will still advertise its deadness
         -- Safe to say that there are no handled-cons for the DEFAULT case
                 -- NB: simplBinder does not zap deadness occ-info, so
                 -- a dead case_bndr' will still advertise its deadness

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 3c84d3a..3388bb4 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -736,7 +736,7 @@ extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
 extendValEnv env _  Nothing   = env
 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
 
 extendValEnv env _  Nothing   = env
 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
 

-extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
+extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])

 -- When we encounter
 --     case scrut of b
 --         C x y -> ...
 -- When we encounter
 --     case scrut of b
 --         C x y -> ...

@@ -744,21 +744,20 @@ extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
 -- NB1: Extends only the sc_vals part of the envt
 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
 --      they are potentially made alive by the [b -> C x y] binding
 -- NB1: Extends only the sc_vals part of the envt
 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
 --      they are potentially made alive by the [b -> C x y] binding

-extendCaseBndrs env case_bndr con alt_bndrs
-  | isDeadBinder case_bndr
-  = (env, alt_bndrs)
-  | otherwise
-  = (env1, map zap alt_bndrs)
-       -- NB: We used to bind v too, if scrut = (Var v); but
-        --     the simplifer has already done this so it seems
-        --     redundant to do so here
-       -- case scrut of
-       --      Var v  -> extendValEnv env1 v cval
-       --      _other -> env1
+extendCaseBndrs env scrut case_bndr con alt_bndrs
+   = (env2, alt_bndrs')

  where
  where

-   zap v | isTyCoVar v = v             -- See NB2 above
-         | otherwise = zapIdOccInfo v
-   env1 = extendValEnv env case_bndr cval
+   live_case_bndr = not (isDeadBinder case_bndr)
+   env1 | Var v <- scrut = extendValEnv env v cval
+        | otherwise      = env -- See Note [Add scrutinee to ValueEnv too]
+   env2 | live_case_bndr = extendValEnv env case_bndr cval
+        | otherwise      = env1
+
+   alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }
+              = map zap alt_bndrs
+              | otherwise
+              = alt_bndrs
+

    cval = case con of
                DEFAULT    -> Nothing
                LitAlt {}  -> Just (ConVal con [])
    cval = case con of
                DEFAULT    -> Nothing
                LitAlt {}  -> Just (ConVal con [])

@@ -767,6 +766,9 @@ extendCaseBndrs env case_bndr con alt_bndrs
                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
                                       varsToCoreExprs alt_bndrs
 
                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
                                       varsToCoreExprs alt_bndrs
 

+   zap v | isTyCoVar v = v             -- See NB2 above
+         | otherwise = zapIdOccInfo v
+

 
 decreaseSpecCount :: ScEnv -> Int -> ScEnv
 -- See Note [Avoiding exponential blowup]
 
 decreaseSpecCount :: ScEnv -> Int -> ScEnv
 -- See Note [Avoiding exponential blowup]

@@ -821,6 +823,25 @@ forceSpecArgTy _ _ = False
 #endif /* GHCI */
 \end{code}
 
 #endif /* GHCI */
 \end{code}
 

+Note [Add scrutinee to ValueEnv too]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+   case x of y
+     (a,b) -> case b of c
+                I# v -> ...(f y)...
+By the time we get to the call (f y), the ValueEnv
+will have a binding for y, and for c
+    y -> (a,b)
+    c -> I# v
+BUT that's not enough!  Looking at the call (f y) we
+see that y is pair (a,b), but we also need to know what 'b' is.
+So in extendCaseBndrs we must *also* add the binding 
+   b -> I# v
+else we lose a useful specialisation for f.  This is necessary even
+though the simplifier has systematically replaced uses of 'x' with 'y'
+and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came
+from outside the case.  See Trac #4908 for the live example.
+

 Note [Avoiding exponential blowup]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The sc_count field of the ScEnv says how many times we are prepared to
 Note [Avoiding exponential blowup]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The sc_count field of the ScEnv says how many times we are prepared to

@@ -1020,9 +1041,9 @@ scExpr' env (Case scrut b ty alts)
          ; return (alt_usg `combineUsage` scrut_usg',
                    Case scrut' b' (scSubstTy env ty) alts') }
 
          ; return (alt_usg `combineUsage` scrut_usg',
                    Case scrut' b' (scSubstTy env ty) alts') }
 

-    sc_alt env _scrut' b' (con,bs,rhs)
-      = do { let (env1, bs1)  = extendBndrsWith RecArg env bs
-                (env2, bs2) = extendCaseBndrs env1 b' con bs1
+    sc_alt env scrut' b' (con,bs,rhs)
+      = do { let (env1, bs1) = extendBndrsWith RecArg env bs
+                (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1

           ; (usg,rhs') <- scExpr env2 rhs
           ; let (usg', arg_occs) = lookupOccs usg bs2
                 scrut_occ = case con of
           ; (usg,rhs') <- scExpr env2 rhs
           ; let (usg', arg_occs) = lookupOccs usg bs2
                 scrut_occ = case con of