diff options
author | Ben Gamari <bgamari.foss@gmail.com> | 2017-07-31 22:33:24 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2017-08-01 08:57:15 -0400 |
commit | 5a7af95ad2ce38e4b80893d869948c630454683b (patch) | |
tree | 7453c3d488fa6b7292166e864dd2114e4f68367b | |
parent | 7a74f5053fa0972b8ce191f7492e1692f09c2e1d (diff) | |
download | haskell-5a7af95ad2ce38e4b80893d869948c630454683b.tar.gz |
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
-rw-r--r-- | compiler/prelude/KnownUniques.hs | 9 | ||||
-rw-r--r-- | testsuite/tests/unboxedsums/T14051.hs | 10 | ||||
-rw-r--r-- | testsuite/tests/unboxedsums/T14051a.hs | 6 | ||||
-rw-r--r-- | 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 8f1b0b6347..60fa0e2435 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 0000000000..96662a946e --- /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 0000000000..b88f70ea05 --- /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 eea818b6f1..45723cb4f0 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']) |