[commit: ghc] wip/T14373: Handle the case when ptr tag is telling no story (83c89b3)

[git at git.haskell.org]

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

On branch  : wip/T14373
Link       : http://ghc.haskell.org/trac/ghc/changeset/83c89b3b5e47c90810c2d47ed39884d3ab439612/ghc

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

commit 83c89b3b5e47c90810c2d47ed39884d3ab439612
Author: Gabor Greif <ggreif at gmail.com>
Date:   Sat Dec 16 14:47:59 2017 +0100

    Handle the case when ptr tag is telling no story
    
    e.g. when we only `\case Fifteenth -> ...`, and
    add a corresponding test.


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

83c89b3b5e47c90810c2d47ed39884d3ab439612
 compiler/codeGen/StgCmmExpr.hs                    | 46 ++++++++++++-----------
 testsuite/tests/codeGen/should_compile/T14373.hs  |  3 ++
 testsuite/tests/codeGen/should_compile/T14373a.hs |  6 +++
 testsuite/tests/codeGen/should_compile/all.T      |  4 ++
 4 files changed, 38 insertions(+), 21 deletions(-)

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 5bb2528..446e421 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -609,7 +609,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
 
         ; let fam_sz   = tyConFamilySize tycon
               bndr_reg = CmmLocal (idToReg dflags bndr)
-              tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)
+              ptag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)
               branches' = first succ <$> branches
               maxpt = mAX_PTR_TAG dflags
               (ptr, info) = partition ((< maxpt) . fst) branches'
@@ -619,30 +619,34 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
                     -- See Note [tagging big families]
         ; if small || null info
            then -- Yes, bndr_reg has constr. tag in ls bits
-               emitSwitch tag_expr branches' mb_deflt 1
+               emitSwitch ptag_expr branches' mb_deflt 1
                  (if small then fam_sz else maxpt) (pure ())
 
            else -- No, get exact tag from info table when mAX_PTR_TAG
               do
-                infos_lbl <- newBlockId -- branch destination for
-                                        -- info pointer lookup
-                infos_scp <- getTickScope
-
-                let catchall = (maxpt, (mkBranch infos_lbl, infos_scp))
-                    prelabel (Just (stmts, scp)) =
-                      do lbl <- newBlockId
-                         return ( Just (mkLabel lbl scp <*> stmts, scp)
-                                , Just (mkBranch lbl, scp))
-                    prelabel _ = return (Nothing, Nothing)
-
-                (mb_deflt, mb_branch) <- prelabel mb_deflt
-                emitSwitch tag_expr (catchall : ptr) mb_deflt 1 maxpt
-                  (do emitLabel infos_lbl
-                      let untagged_ptr = cmmUntag dflags (CmmReg bndr_reg)
-                          tag_expr = getConstrTag dflags untagged_ptr
-                          info0 = first pred <$> info
-                      emitSwitch tag_expr info0 mb_branch
-                        (maxpt - 1) (fam_sz - 1) (pure ()))
+                let untagged_ptr = cmmUntag dflags (CmmReg bndr_reg)
+                    itag_expr = getConstrTag dflags untagged_ptr
+                    info0 = first pred <$> info
+                if null ptr then
+                  emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1) (pure ())
+                else do
+                  infos_lbl <- newBlockId -- branch destination for
+                                          -- info pointer lookup
+                  infos_scp <- getTickScope
+
+                  let catchall = (maxpt, (mkBranch infos_lbl, infos_scp))
+                      prelabel (Just (stmts, scp)) =
+                        do lbl <- newBlockId
+                           return ( Just (mkLabel lbl scp <*> stmts, scp)
+                                  , Just (mkBranch lbl, scp))
+                      prelabel _ = return (Nothing, Nothing)
+
+                  (mb_deflt, mb_branch) <- prelabel mb_deflt
+
+                  emitSwitch ptag_expr (catchall : ptr) mb_deflt 1 maxpt
+                    (do emitLabel infos_lbl
+                        emitSwitch itag_expr info0 mb_branch
+                          (maxpt - 1) (fam_sz - 1) (pure ()))
 
         ; return AssignedDirectly }
 
diff --git a/testsuite/tests/codeGen/should_compile/T14373.hs b/testsuite/tests/codeGen/should_compile/T14373.hs
new file mode 100644
index 0000000..9ab2242
--- /dev/null
+++ b/testsuite/tests/codeGen/should_compile/T14373.hs
@@ -0,0 +1,3 @@
+module T14373 where
+
+data BigFam = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P deriving (Enum, Show)
diff --git a/testsuite/tests/codeGen/should_compile/T14373a.hs b/testsuite/tests/codeGen/should_compile/T14373a.hs
new file mode 100644
index 0000000..7cce120
--- /dev/null
+++ b/testsuite/tests/codeGen/should_compile/T14373a.hs
@@ -0,0 +1,6 @@
+import T14373
+
+{-# NOINLINE lateSwitch #-}
+lateSwitch P = "Cool"
+
+main = putStrLn $ lateSwitch P
diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T
index 6ae4e1c..4ee2dbf 100644
--- a/testsuite/tests/codeGen/should_compile/all.T
+++ b/testsuite/tests/codeGen/should_compile/all.T
@@ -35,3 +35,7 @@ test('T10667', [ when((arch('powerpc64') or arch('powerpc64le')),
      compile, ['-g'])
 test('T12115', normal, compile, [''])
 test('T12355', normal, compile, [''])
+#test('T14373', [extra_files(['T14373.hs', 'T14373a.hs'])],
+#     multimod_compile, [''])
+test('T14373', [],
+     multimod_compile, ['T14373a', '-O2 -c -ddump-cmm-from-stg -dsuppress-uniques'])