diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs | 33 | ||||
| -rw-r--r-- | testsuite/tests/lib/integer/all.T | 9 | ||||
| -rw-r--r-- | testsuite/tests/numeric/should_compile/T14465.stdout | 8 | ||||
| -rw-r--r-- | testsuite/tests/numeric/should_compile/T19892.hs | 16 | ||||
| -rw-r--r-- | testsuite/tests/numeric/should_compile/T19892.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/numeric/should_compile/all.T | 1 |
6 files changed, 59 insertions, 12 deletions
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 63175e1b99..e6cf3b1da0 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -1784,7 +1784,7 @@ builtinBignumRules = , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalName False False , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False - , lit_to_natural "Word# -> Natural" naturalNSDataConName + , lit_to_natural "Word# -> Natural" naturalNSName , natural_to_word "Natural -> Word# (wrap)" naturalToWordName False , natural_to_word "Natural -> Word# (clamp)" naturalToWordClampName True @@ -1857,21 +1857,21 @@ builtinBignumRules = , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap -- identity passthrough - , id_passthrough "Int# -> Integer -> Int#" integerToIntName integerISDataConName + , id_passthrough "Int# -> Integer -> Int#" integerToIntName integerISName , id_passthrough "Word# -> Integer -> Word#" integerToWordName integerFromWordName , id_passthrough "Int64# -> Integer -> Int64#" integerToInt64Name integerFromInt64Name , id_passthrough "Word64# -> Integer -> Word64#" integerToWord64Name integerFromWord64Name - , id_passthrough "Word# -> Natural -> Word#" naturalToWordName naturalNSDataConName + , id_passthrough "Word# -> Natural -> Word#" naturalToWordName naturalNSName -- identity passthrough with a conversion that can be done directly instead , small_passthrough "Int# -> Integer -> Word#" - integerISDataConName integerToWordName (mkPrimOpId IntToWordOp) + integerISName integerToWordName (mkPrimOpId IntToWordOp) , small_passthrough "Int# -> Integer -> Float#" - integerISDataConName integerToFloatName (mkPrimOpId IntToFloatOp) + integerISName integerToFloatName (mkPrimOpId IntToFloatOp) , small_passthrough "Int# -> Integer -> Double#" - integerISDataConName integerToDoubleName (mkPrimOpId IntToDoubleOp) + integerISName integerToDoubleName (mkPrimOpId IntToDoubleOp) , small_passthrough "Word# -> Natural -> Int#" - naturalNSDataConName naturalToWordName (mkPrimOpId WordToIntOp) + naturalNSName naturalToWordName (mkPrimOpId WordToIntOp) -- Bits.bit , bignum_bit "integerBit" integerBitName mkLitInteger @@ -1908,6 +1908,25 @@ builtinBignumRules = , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble ] where + -- The rule is matching against an occurrence of a data constructor in a + -- Core expression. It must match either its worker name or its wrapper + -- name, /not/ the DataCon name itself, which is different. + -- See Note [Data Constructor Naming] in GHC.Core.DataCon and #19892 + -- + -- But data constructor wrappers deliberately inline late; See Note + -- [Activation for data constructor wrappers] in GHC.Types.Id.Make. + -- Suppose there is a wrapper and the rule matches on the worker: the + -- wrapper won't be inlined until rules have finished firing and the rule + -- will never fire. + -- + -- Hence the rule must match on the wrapper, if there is one, otherwise on + -- the worker. That is exactly the dataConWrapId for the data constructor. + -- The data constructor may or may not have a wrapper, but if not + -- dataConWrapId will return the worker + -- + integerISName = idName (dataConWrapId integerISDataCon) + naturalNSName = idName (dataConWrapId naturalNSDataCon) + mkRule str name nargs f = BuiltinRule { ru_name = fsLit str , ru_fn = name diff --git a/testsuite/tests/lib/integer/all.T b/testsuite/tests/lib/integer/all.T index 7c9720ed1f..c6710c69a1 100644 --- a/testsuite/tests/lib/integer/all.T +++ b/testsuite/tests/lib/integer/all.T @@ -4,7 +4,14 @@ test('integerConversions', normal, compile_and_run, ['']) test('plusMinusInteger', [omit_ways(['ghci'])], compile_and_run, ['']) test('integerConstantFolding', normal, makefile_test, ['integerConstantFolding']) test('naturalConstantFolding', normal, makefile_test, ['naturalConstantFolding']) -test('fromToInteger', [], makefile_test, ['fromToInteger']) + +# we ignore_stderr because there are 2 overlapping rules that are reported in +# debug mode: +# Rules.findBest: rule overlap (Rule 1 wins) +# Rule 1: "Integer -> Int# (wrap)" +# Rule 2: "Int# -> Integer -> Int#" +test('fromToInteger', [ignore_stderr], makefile_test, ['fromToInteger']) + test('IntegerConversionRules', [], makefile_test, ['IntegerConversionRules']) test('gcdInteger', normal, compile_and_run, ['']) test('gcdeInteger', normal, compile_and_run, ['']) diff --git a/testsuite/tests/numeric/should_compile/T14465.stdout b/testsuite/tests/numeric/should_compile/T14465.stdout index 970ceb4fd2..00d3101eb4 100644 --- a/testsuite/tests/numeric/should_compile/T14465.stdout +++ b/testsuite/tests/numeric/should_compile/T14465.stdout @@ -1,14 +1,14 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 35, types: 14, coercions: 0, joins: 0/0} + = {terms: 34, types: 14, coercions: 0, joins: 0/0} --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} ten :: Natural [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -ten = GHC.Num.Natural.NS 10## + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] +ten = 10 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} M.$trModule4 :: GHC.Prim.Addr# diff --git a/testsuite/tests/numeric/should_compile/T19892.hs b/testsuite/tests/numeric/should_compile/T19892.hs new file mode 100644 index 0000000000..cd8d9018b8 --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T19892.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MagicHash #-} + +module T19892 where + +import GHC.Exts +import GHC.Num.Integer +import GHC.Num.Natural + +foo :: Word# -> Word# +foo x = integerToWord# (IS (word2Int# x)) + +bar :: Int# -> Int# +bar x = integerToInt# (IS x) + +baz :: Word# -> Word# +baz x = naturalToWord# (NS x) diff --git a/testsuite/tests/numeric/should_compile/T19892.stderr b/testsuite/tests/numeric/should_compile/T19892.stderr new file mode 100644 index 0000000000..89411a6df9 --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T19892.stderr @@ -0,0 +1,4 @@ +Rule fired: Int# -> Integer -> Word# (BUILTIN) +Rule fired: int2Word# (BUILTIN) +Rule fired: Int# -> Integer -> Int# (BUILTIN) +Rule fired: Word# -> Natural -> Word# (BUILTIN) diff --git a/testsuite/tests/numeric/should_compile/all.T b/testsuite/tests/numeric/should_compile/all.T index 8f0b268690..766dda4814 100644 --- a/testsuite/tests/numeric/should_compile/all.T +++ b/testsuite/tests/numeric/should_compile/all.T @@ -9,3 +9,4 @@ test('T7881', normal, compile, ['']) test('T8542', omit_ways(['hpc']), compile, ['']) test('T10929', normal, compile, ['']) test('T16402', [ grep_errmsg(r'and'), when(wordsize(32), expect_broken(19024)) ], compile, ['']) +test('T19892', normal, compile, ['-O -ddump-rule-firings']) |