[commit: ghc] ghc-8.4: Fix utterly bogus TagToEnum rule in caseRules (4e0b4b3)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.4
Link       : http://ghc.haskell.org/trac/ghc/changeset/4e0b4b36aca29b4d67df5f36d1a06bdfdfeec612/ghc

>---------------------------------------------------------------

commit 4e0b4b36aca29b4d67df5f36d1a06bdfdfeec612
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Feb 7 09:55:14 2018 +0000

    Fix utterly bogus TagToEnum rule in caseRules
    
    In prelRules we had:
    
      tx_con_tte :: DynFlags -> AltCon -> AltCon
      tx_con_tte _      DEFAULT      = DEFAULT
      tx_con_tte dflags (DataAlt dc)
        | tag == 0  = DEFAULT   -- See Note [caseRules for tagToEnum]
        | otherwise = LitAlt (mkMachInt dflags (toInteger tag))
    
    The tag==0 case is totally wrong, and led directly to Trac #14768.
    
    See "Beware" in Note [caseRules for tagToEnum] (in the patch).
    
    Easily fixed, though!
    
    (cherry picked from commit 4aa98f4a3cb0c965c4df19af2f1ccc2c5483c3a5)


>---------------------------------------------------------------

4e0b4b36aca29b4d67df5f36d1a06bdfdfeec612
 compiler/coreSyn/CoreLint.hs     |  2 +-
 compiler/prelude/PrelRules.hs    | 39 ++++++++++++++++++++++++++-------------
 compiler/simplCore/SimplUtils.hs | 28 +++++++++++++++++++++++++---
 3 files changed, 52 insertions(+), 17 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 17fa980..2665c1e 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -1123,7 +1123,7 @@ checkCaseAlts e ty alts =
   where
     (con_alts, maybe_deflt) = findDefault alts
 
-        -- Check that successive alternatives have increasing tags
+        -- Check that successive alternatives have strictly increasing tags
     increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
     increasing_tag _                         = True
 
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 80a1145..b475637 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -1500,13 +1500,10 @@ adjustUnary op
          _         -> Nothing
 
 tx_con_tte :: DynFlags -> AltCon -> AltCon
-tx_con_tte _      DEFAULT      = DEFAULT
-tx_con_tte dflags (DataAlt dc)
-  | tag == 0  = DEFAULT   -- See Note [caseRules for tagToEnum]
-  | otherwise = LitAlt (mkMachInt dflags (toInteger tag))
-  where
-    tag = dataConTagZ dc
-tx_con_tte _      alt          = pprPanic "caseRules" (ppr alt)
+tx_con_tte _      DEFAULT         = DEFAULT
+tx_con_tte _      alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)
+tx_con_tte dflags (DataAlt dc)  -- See Note [caseRules for tagToEnum]
+  = LitAlt $ mkMachInt dflags $ toInteger $ dataConTagZ dc
 
 tx_con_dtt :: Type -> AltCon -> AltCon
 tx_con_dtt _  DEFAULT              = DEFAULT
@@ -1525,18 +1522,34 @@ We want to transform
 into
    case x of
      0# -> e1
-     1# -> e1
+     1# -> e2
 
 This rule eliminates a lot of boilerplate. For
-  if (x>y) then e1 else e2
+  if (x>y) then e2 else e1
 we generate
   case tagToEnum (x ># y) of
-    False -> e2
-    True  -> e1
+    False -> e1
+    True  -> e2
 and it is nice to then get rid of the tagToEnum.
 
-NB: in SimplUtils, where we invoke caseRules,
-    we convert that 0# to DEFAULT
+Beware (Trac #14768): avoid the temptation to map constructor 0 to
+DEFAULT, in the hope of getting this
+  case (x ># y) of
+    DEFAULT -> e1
+    1#      -> e2
+That fails utterly in the case of
+   data Colour = Red | Green | Blue
+   case tagToEnum x of
+      DEFAULT -> e1
+      Red     -> e2
+
+We don't want to get this!
+   case x of
+      DEFAULT -> e1
+      DEFAULT -> e2
+
+Instead, we deal with turning one branch into DEAFULT in SimplUtils
+(add_default in mkCase3).
 
 Note [caseRules for dataToTag]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index f2cf7a6..9f652db 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -2153,12 +2153,34 @@ mkCase2 dflags scrut bndr alts_ty alts
     re_sort alts = sortBy cmpAlt alts  -- preserve the #case_invariants#
 
     add_default :: [CoreAlt] -> [CoreAlt]
-    -- TagToEnum may change a boolean True/False set of alternatives
-    -- to LitAlt 0#/1# alterantives.  But literal alternatives always
-    -- have a DEFAULT (I think).  So add it.
+    -- See Note [Literal cases]
     add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts
     add_default alts                          = alts
 
+{- Note [Literal cases]
+~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+  case tagToEnum (a ># b) of
+     False -> e1
+     True  -> e2
+
+then caseRules for TagToEnum will turn it into
+  case tagToEnum (a ># b) of
+     0# -> e1
+     1# -> e2
+
+Since the case is exhaustive (all cases are) we can convert it to
+  case tagToEnum (a ># b) of
+     DEFAULT -> e1
+     1#      -> e2
+
+This may generate sligthtly better code (although it should not, since
+all cases are exhaustive) and/or optimise better.  I'm not certain that
+it's necessary, but currenty we do make this change.  We do it here,
+NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum]
+in PrelRules)
+-}
+
 --------------------------------------------------
 --      Catch-all
 --------------------------------------------------