[commit: ghc] ghc-8.2: KnownUniques: Handle DataCon wrapper names (fe53505)

[git at git.haskell.org]

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

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/fe5350561dccb1913c2bdde2cd76d5513350b2cf/ghc

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

commit fe5350561dccb1913c2bdde2cd76d5513350b2cf
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Mon Jul 31 22:33:24 2017 -0400

    KnownUniques: Handle DataCon wrapper names
    
    For some reason these weren't handled. I seem to remember thinking I had
    a reason for omitting them when writing the original patch, but I don't
    recall what that reason was at this point and clearly workers do show up
    in interface files.
    
    Test Plan: Validate against T14051
    
    Reviewers: austin
    
    Subscribers: rwbarton, thomie, RyanGlScott
    
    GHC Trac Issues: #14051
    
    Differential Revision: https://phabricator.haskell.org/D3805
    
    (cherry picked from commit 5a7af95ad2ce38e4b80893d869948c630454683b)


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

fe5350561dccb1913c2bdde2cd76d5513350b2cf
 compiler/prelude/KnownUniques.hs       |  9 ++++++---
 testsuite/tests/unboxedsums/T14051.hs  | 10 ++++++++++
 testsuite/tests/unboxedsums/T14051a.hs |  6 ++++++
 testsuite/tests/unboxedsums/all.T      |  1 +
 4 files changed, 23 insertions(+), 3 deletions(-)

diff --git a/compiler/prelude/KnownUniques.hs b/compiler/prelude/KnownUniques.hs
index 8f1b0b6..60fa0e2 100644
--- a/compiler/prelude/KnownUniques.hs
+++ b/compiler/prelude/KnownUniques.hs
@@ -79,7 +79,8 @@ knownUniqueName u =
 
 mkSumTyConUnique :: Arity -> Unique
 mkSumTyConUnique arity =
-    ASSERT(arity < 0xff)
+    ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the
+                         -- alternative
     mkUnique 'z' (arity `shiftL` 8 .|. 0xfc)
 
 mkSumDataConUnique :: ConTagZ -> Arity -> Unique
@@ -98,16 +99,18 @@ getUnboxedSumName n
       _   -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag)
   | tag == 0x0
   = dataConName $ sumDataCon (alt + 1) arity
+  | tag == 0x1
+  = getName $ dataConWrapId $ sumDataCon (alt + 1) arity
   | tag == 0x2
   = getRep $ promoteDataCon $ sumDataCon (alt + 1) arity
   | otherwise
   = pprPanic "getUnboxedSumName" (ppr n)
   where
     arity = n `shiftR` 8
-    alt = (n .&. 0xff) `shiftR` 2
+    alt = (n .&. 0xfc) `shiftR` 2
     tag = 0x3 .&. n
     getRep tycon =
-        fromMaybe (pprPanic "getUnboxedSumName" (ppr tycon))
+        fromMaybe (pprPanic "getUnboxedSumName(getRep)" (ppr tycon))
         $ tyConRepName_maybe tycon
 
 -- Note [Uniques for tuple type and data constructors]
diff --git a/testsuite/tests/unboxedsums/T14051.hs b/testsuite/tests/unboxedsums/T14051.hs
new file mode 100644
index 0000000..96662a9
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T14051.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE UnboxedSums #-}
+
+module Main where
+
+import T14051a
+
+main :: IO ()
+main = print $ case func () of
+  (# True | #) -> 123
+  _ -> 321
diff --git a/testsuite/tests/unboxedsums/T14051a.hs b/testsuite/tests/unboxedsums/T14051a.hs
new file mode 100644
index 0000000..b88f70e
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T14051a.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE UnboxedSums #-}
+
+module T14051a where
+
+func :: s -> (# Bool | Bool #)
+func _ = (# True | #)
diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T
index eea818b..45723cb 100644
--- a/testsuite/tests/unboxedsums/all.T
+++ b/testsuite/tests/unboxedsums/all.T
@@ -32,3 +32,4 @@ test('T12711', only_ways(['ghci']), ghci_script, ['T12711.script'])
 #      ['$MAKE -s --no-print-directory sum_api_annots'])
 
 test('UbxSumLevPoly', normal, compile, [''])
+test('T14051', normal, multi_compile, ['T14051.hs', [('T14051a.hs', '')], '-O2 -v0'])