Fix Trac #3717 by making exprOkForSpeculation a bit cleverer

The main change here is to do with dropping redundant seqs.
See Note [exprOkForSpeculation: case expressions] in CoreUtils.

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index d74c278..61bfd2e 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -631,6 +631,11 @@ it's applied only to dictionaries.
 --
 --  * Safe /not/ to evaluate even if normal order would do so
 --
 --
 --  * Safe /not/ to evaluate even if normal order would do so
 --

+-- It is usually called on arguments of unlifted type, but not always
+-- In particular, Simplify.rebuildCase calls it on lifted types
+-- when a 'case' is a plain 'seq'. See the example in 
+-- Note [exprOkForSpeculation: case expressions] below
+--

 -- Precisely, it returns @True@ iff:
 --
 --  * The expression guarantees to terminate, 
 -- Precisely, it returns @True@ iff:
 --
 --  * The expression guarantees to terminate, 

@@ -656,9 +661,14 @@ it's applied only to dictionaries.
 exprOkForSpeculation :: CoreExpr -> Bool
 exprOkForSpeculation (Lit _)     = True
 exprOkForSpeculation (Type _)    = True
 exprOkForSpeculation :: CoreExpr -> Bool
 exprOkForSpeculation (Lit _)     = True
 exprOkForSpeculation (Type _)    = True

-    -- Tick boxes are *not* suitable for speculation
-exprOkForSpeculation (Var v)     = isUnLiftedType (idType v)
-                                && not (isTickBoxOp v)
+
+exprOkForSpeculation (Var v)     
+  | isTickBoxOp v = False     -- Tick boxes are *not* suitable for speculation
+  | otherwise     =  isUnLiftedType (idType v) -- c.f. the Var case of exprIsHNF
+                 || isDataConWorkId v          -- Nullary constructors
+                 || idArity v > 0              -- Functions
+                 || isEvaldUnfolding (idUnfolding v)   -- Let-bound values
+

 exprOkForSpeculation (Note _ e)  = exprOkForSpeculation e
 exprOkForSpeculation (Cast e _)  = exprOkForSpeculation e
 
 exprOkForSpeculation (Note _ e)  = exprOkForSpeculation e
 exprOkForSpeculation (Cast e _)  = exprOkForSpeculation e
 

@@ -718,7 +728,6 @@ isDivOp _                = False
 
 Note [exprOkForSpeculation: case expressions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
 
 Note [exprOkForSpeculation: case expressions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 

-

 It's always sound for exprOkForSpeculation to return False, and we
 don't want it to take too long, so it bales out on complicated-looking
 terms.  Notably lets, which can be stacked very deeply; and in any 
 It's always sound for exprOkForSpeculation to return False, and we
 don't want it to take too long, so it bales out on complicated-looking
 terms.  Notably lets, which can be stacked very deeply; and in any 

@@ -726,7 +735,7 @@ case the argument of exprOkForSpeculation is usually in a strict context,
 so any lets will have been floated away.
 
 However, we keep going on case-expressions.  An example like this one
 so any lets will have been floated away.
 
 However, we keep going on case-expressions.  An example like this one

-showed up in DPH code:
+showed up in DPH code (Trac #3717):

     foo :: Int -> Int
     foo 0 = 0
     foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)
     foo :: Int -> Int
     foo 0 = 0
     foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 6bc7e0b..6fe24df 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1420,7 +1420,7 @@ So it's up to the programmer: rules can cause divergence
 
 %************************************************************************
 %*                                                                      *
 
 %************************************************************************
 %*                                                                      *

-                Rebuilding a cse expression
+                Rebuilding a case expression

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

@@ -1429,7 +1429,7 @@ Note [Case elimination]
 The case-elimination transformation discards redundant case expressions.
 Start with a simple situation:
 
 The case-elimination transformation discards redundant case expressions.
 Start with a simple situation:
 

-        case x# of      ===>   e[x#/y#]
+        case x# of      ===>   let y# = x# in e

           y# -> e
 
 (when x#, y# are of primitive type, of course).  We can't (in general)
           y# -> e
 
 (when x#, y# are of primitive type, of course).  We can't (in general)

@@ -1450,29 +1450,40 @@ Here the inner case is first trimmed to have only one alternative, the
 DEFAULT, after which it's an instance of the previous case.  This
 really only shows up in eliminating error-checking code.
 
 DEFAULT, after which it's an instance of the previous case.  This
 really only shows up in eliminating error-checking code.
 

-We also make sure that we deal with this very common case:
-
-        case e of
-          x -> ...x...
-
-Here we are using the case as a strict let; if x is used only once
-then we want to inline it.  We have to be careful that this doesn't
-make the program terminate when it would have diverged before, so we
-check that
-        - e is already evaluated (it may so if e is a variable)
-        - x is used strictly, or
-
-Lastly, the code in SimplUtils.mkCase combines identical RHSs.  So
+Note that SimplUtils.mkCase combines identical RHSs.  So

 
         case e of       ===> case e of DEFAULT -> r
            True  -> r
            False -> r
 
 Now again the case may be elminated by the CaseElim transformation.
 
         case e of       ===> case e of DEFAULT -> r
            True  -> r
            False -> r
 
 Now again the case may be elminated by the CaseElim transformation.

+This includes things like (==# a# b#)::Bool so that we simplify
+      case ==# a# b# of { True -> x; False -> x }
+to just
+      x
+This particular example shows up in default methods for
+comparision operations (e.g. in (>=) for Int.Int32)

 
 Note [CaseElimination: lifted case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [CaseElimination: lifted case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

-We do not use exprOkForSpeculation in the lifted case.  Consider
+We also make sure that we deal with this very common case,
+where x has a lifted type:
+
+        case e of
+          x -> ...x...
+
+Here we are using the case as a strict let; if x is used only once
+then we want to inline it.  We have to be careful that this doesn't
+make the program terminate when it would have diverged before, so we
+check that
+        (a) 'e' is already evaluated (it may so if e is a variable)
+           Specifically we check (exprIsHNF e)
+or
+        (b) the scrutinee is a variable and 'x' is used strictly
+or
+        (c) 'x' is not used at all and e is ok-for-speculation
+
+For the (c), consider

    case (case a ># b of { True -> (p,q); False -> (q,p) }) of
      r -> blah
 The scrutinee is ok-for-speculation (it looks inside cases), but we do
    case (case a ># b of { True -> (p,q); False -> (q,p) }) of
      r -> blah
 The scrutinee is ok-for-speculation (it looks inside cases), but we do

@@ -1572,33 +1583,33 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
   -- then there is now only one (DEFAULT) rhs
  | all isDeadBinder bndrs       -- bndrs are [InId]
 
   -- then there is now only one (DEFAULT) rhs
  | all isDeadBinder bndrs       -- bndrs are [InId]
 

-        -- Check that the scrutinee can be let-bound instead of case-bound

  , if isUnLiftedType (idType case_bndr)
  , if isUnLiftedType (idType case_bndr)

-   then exprOkForSpeculation scrut
-        -- Satisfy the let-binding invariant
-        -- This includes things like (==# a# b#)::Bool
-        -- so that we simplify
-        --      case ==# a# b# of { True -> x; False -> x }
-        -- to just
-        --      x
-        -- This particular example shows up in default methods for
-        -- comparision operations (e.g. in (>=) for Int.Int32)
-
-   else exprIsHNF scrut || var_demanded_later scrut
-        -- It's already evaluated, or will be demanded later
-        -- See Note [Case elimination: lifted case]
+   then ok_for_spec         -- Satisfy the let-binding invariant
+   else elim_lifted

   = do  { tick (CaseElim case_bndr)
         ; env' <- simplNonRecX env case_bndr scrut
           -- If case_bndr is deads, simplNonRecX will discard
         ; simplExprF env' rhs cont }
   where
   = do  { tick (CaseElim case_bndr)
         ; env' <- simplNonRecX env case_bndr scrut
           -- If case_bndr is deads, simplNonRecX will discard
         ; simplExprF env' rhs cont }
   where

-        -- The case binder is going to be evaluated later,
-        -- and the scrutinee is a simple variable
-    var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr)
-                                 && not (isTickBoxOp v)
+    elim_lifted   -- See Note [Case elimination: lifted case]
+      = exprIsHNF scrut
+     || (strict_case_bndr && scrut_is_var scrut) 
+              -- The case binder is going to be evaluated later,
+              -- and the scrutinee is a simple variable
+
+     || (is_plain_seq && ok_for_spec)
+              -- Note: not the same as exprIsHNF
+
+    ok_for_spec      = exprOkForSpeculation scrut
+    is_plain_seq     = isDeadBinder case_bndr  -- Evaluation *only* for effect
+    strict_case_bndr = isStrictDmd (idDemandInfo case_bndr)
+
+    scrut_is_var (Cast s _) = scrut_is_var s
+    scrut_is_var (Var v)    = not (isTickBoxOp v)

                                     -- ugly hack; covering this case is what
                                     -- exprOkForSpeculation was intended for.
                                     -- ugly hack; covering this case is what
                                     -- exprOkForSpeculation was intended for.

-    var_demanded_later _       = False
+    scrut_is_var _          = False
+

 
 --------------------------------------------------
 --      3. Try seq rules; see Note [User-defined RULES for seq] in MkId
 
 --------------------------------------------------
 --      3. Try seq rules; see Note [User-defined RULES for seq] in MkId

@@ -1764,7 +1775,7 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
           -> SimplM (SimplEnv, OutExpr, OutId)
 -- Note [Improving seq]
 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
           -> SimplM (SimplEnv, OutExpr, OutId)
 -- Note [Improving seq]
 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]

-  | not (isDeadBinder case_bndr)       -- Not a pure seq!  See the Note!
+  | not (isDeadBinder case_bndr)       -- Not a pure seq!  See Note [Improving seq]

   , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
   = do { case_bndr2 <- newId (fsLit "nt") ty2
         ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
   , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
   = do { case_bndr2 <- newId (fsLit "nt") ty2
         ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)