Run StgCse after unarise, fixes #15300

Given two unboxed sum terms:

    (# 1 | #) :: (# Int | Int# #)
    (# 1 | #) :: (# Int | Int  #)

These two terms are not equal as they unarise to different unboxed
tuples. However StgCse was thinking that these are equal, and replacing
one of these with a binder to the other.

To not deal with unboxed sums in StgCse we now do it after unarise. For
StgCse to maintain post-unarise invariants we factor-out case binder
in-scopeness check to `stgCaseBndrInScope` and use it in StgCse.

Also did some refactoring in SimplStg.

Another way to fix this would be adding a special case in StgCse to not
bring unboxed sum binders in scope:

    diff --git a/compiler/simplStg/StgCse.hs
b/compiler/simplStg/StgCse.hs
    index 6c740ca4cb..93a0f8f6ad 100644
    --- a/compiler/simplStg/StgCse.hs
    +++ b/compiler/simplStg/StgCse.hs
    @@ -332,7 +332,11 @@ stgCseExpr env (StgLetNoEscape binds body)
     stgCseAlt :: CseEnv -> OutId -> InStgAlt -> OutStgAlt
     stgCseAlt env case_bndr (DataAlt dataCon, args, rhs)
         = let (env1, args') = substBndrs env args
    -          env2 = addDataCon case_bndr dataCon (map StgVarArg
args') env1
    +          env2
    +            | isUnboxedSumCon dataCon
    +            = env1
    +            | otherwise
    +            = addDataCon case_bndr dataCon (map StgVarArg args')
env1
                 -- see note [Case 2: CSEing case binders]
               rhs' = stgCseExpr env2 rhs
           in (DataAlt dataCon, args', rhs')

I think this patch seems better in that it doesn't add a special case to
StgCse.

Test Plan:
Validate.

I tried to come up with a minimal example but failed. I thought a simple
program like

    data T = T (# Int | Int #) (# Int# | Int #)

    case T (# 1 | #) (# 1 | #) of ...

should be enough to trigger this bug, but for some reason StgCse
doesn't do
anything on this program.

Reviewers: simonpj, bgamari

Reviewed By: simonpj

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #15300

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

1 files changed, 8 insertions, 18 deletions

diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
index 854bb92258..36bf5101d6 100644
--- a/compiler/simplStg/SimplStg.hs
+++ b/compiler/simplStg/SimplStg.hs
@@ -21,7 +21,6 @@ import StgCse           ( stgCse )
 
 import DynFlags
 import ErrUtils
-import SrcLoc
 import UniqSupply       ( mkSplitUniqSupply )
 import Outputable
 import Control.Monad
@@ -34,27 +33,19 @@ stg2stg dflags binds
   = do  { showPass dflags "Stg2Stg"
         ; us <- mkSplitUniqSupply 'g'
 
-        ; when (dopt Opt_D_verbose_stg2stg dflags)
-               (putLogMsg dflags NoReason SevDump noSrcSpan
-                  (defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:"))
-
-        ; binds' <- end_pass "Stg2Stg" binds
-
                 -- Do the main business!
-        ; processed_binds <- foldM do_stg_pass binds' (getStgToDo dflags)
-
         ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
-                        (pprStgTopBindings processed_binds)
-
-        ; let un_binds = unarise us processed_binds
+                        (pprStgTopBindings binds)
 
+        ; stg_linter False "Pre-unarise" binds
+        ; let un_binds = unarise us binds
         ; stg_linter True "Unarise" un_binds
 
         ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
                         (pprStgTopBindings un_binds)
 
-        ; return un_binds
-   }
+        ; foldM do_stg_pass un_binds (getStgToDo dflags)
+        }
 
   where
     stg_linter unarised
@@ -65,8 +56,7 @@ stg2stg dflags binds
     do_stg_pass binds to_do
       = case to_do of
           D_stg_stats ->
-             trace (showStgStats binds)
-             end_pass "StgStats" binds
+             trace (showStgStats binds) (return binds)
 
           StgCSE ->
              {-# SCC "StgCse" #-}
@@ -78,8 +68,8 @@ stg2stg dflags binds
     end_pass what binds2
       = do -- report verbosely, if required
            dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
-              (vcat (map ppr binds2))
-           stg_linter False what binds2
+              (pprStgTopBindings binds2)
+           stg_linter True what binds2
            return binds2
 
 -- -----------------------------------------------------------------------------