KnownUniques: Handle DataCon wrapper names
authorBen Gamari <bgamari.foss@gmail.com>
Tue, 1 Aug 2017 02:33:24 +0000 (22:33 -0400)
committerBen Gamari <ben@smart-cactus.org>
Tue, 1 Aug 2017 12:57:15 +0000 (08:57 -0400)
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

compiler/prelude/KnownUniques.hs
testsuite/tests/unboxedsums/T14051.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/T14051a.hs [new file with mode: 0644]
testsuite/tests/unboxedsums/all.T

index 8f1b0b6..60fa0e2 100644 (file)
@@ -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 (file)
index 0000000..96662a9
--- /dev/null
@@ -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 (file)
index 0000000..b88f70e
--- /dev/null
@@ -0,0 +1,6 @@
+{-# LANGUAGE UnboxedSums #-}
+
+module T14051a where
+
+func :: s -> (# Bool | Bool #)
+func _ = (# True | #)
index eea818b..45723cb 100644 (file)
@@ -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'])