Bignum: add Natural constant folding rules (#15821)

* Implement constant folding rules for Natural (similar to Integer ones)

* Add mkCoreUbxSum helper in GHC.Core.Make

* Remove naturalTo/FromInt

  We now only provide `naturalTo/FromWord` as
  the semantics is clear (truncate/zero-extend). For Int we have to deal
  with negative numbers (throw an exception? convert to Word
  beforehand?) so we leave the decision about what to do to the caller.

  Moreover, now that we have sized types (Int8#, Int16#, ..., Word8#,
  etc.) there is no reason to bless `Int#` more than `Int8#` or `Word8#`
  (for example).

* Replaced a few `()` with `(# #)`

5 files changed, 259 insertions, 4 deletions

diff --git a/testsuite/tests/lib/integer/Makefile b/testsuite/tests/lib/integer/Makefile
index aa2704ab6d..4292a1b970 100644
--- a/testsuite/tests/lib/integer/Makefile
+++ b/testsuite/tests/lib/integer/Makefile
@@ -2,14 +2,18 @@ TOP=../../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/test.mk
 
-CHECK = grep -q -- '$1' integerConstantFolding.simpl || \
+CHECK = grep -q -- '$1' folding.simpl || \
         echo "$2 didn't constant fold"
 
+CHECK2 = grep -q -- '$1' folding.simpl || \
+	 grep -q -- '$2' folding.simpl || \
+	 echo "$3 didn't constant fold"
+
 .PHONY: integerConstantFolding
 integerConstantFolding:
-	'$(TEST_HC)' -Wall -v0 -O --make integerConstantFolding -fforce-recomp -ddump-simpl > integerConstantFolding.simpl
+	'$(TEST_HC)' -Wall -v0 -O --make integerConstantFolding -fforce-recomp -ddump-simpl > folding.simpl
 # All the 100nnn values should be constant-folded away
-	! grep -q '\<100[0-9][0-9][0-9]\>' integerConstantFolding.simpl || { echo "Unfolded values found"; grep '\<100[0-9][0-9][0-9]\>' integerConstantFolding.simpl; }
+	! grep -q '\<100[0-9][0-9][0-9]\>' folding.simpl || { echo "Unfolded values found"; grep '\<100[0-9][0-9][0-9]\>' folding.simpl; }
 	$(call CHECK,\<200007\>,plusInteger)
 	$(call CHECK,\<683234160\>,timesInteger)
 	$(call CHECK,-991\>,minusIntegerN)
@@ -58,3 +62,43 @@ IntegerConversionRules:
 	-grep -q integerToWord     $@.simpl && echo "integerToWord present"
 	-grep -q int2Word          $@.simpl || echo "int2Word absent"
 
+.PHONY: naturalConstantFolding
+naturalConstantFolding:
+	'$(TEST_HC)' -Wall -v0 -O --make naturalConstantFolding -fforce-recomp -ddump-simpl > folding.simpl
+# All the 100nnn values should be constant-folded away
+	! grep -q '\<100[0-9][0-9][0-9]\>' folding.simpl || { echo "Unfolded values found"; grep '\<100[0-9][0-9][0-9]\>' folding.simpl; }
+	# Bit arithmetic
+	$(call CHECK,\<532\>,andNatural)
+	$(call CHECK,\<239055\>,xorNatural)
+	$(call CHECK,\<16\>,bitNatural)
+	$(call CHECK,\<239579\>,orNatural)
+	$(call CHECK,\<1601040\>,shiftLNatural)
+	$(call CHECK,\<6254\>,shiftRNatural)
+	$(call CHECK,\<6\>,popCountNatural)
+	# Arithmetic
+	$(call CHECK,\<200121\>,plusNatural)
+	$(call CHECK,\<683678240\>,timesNatural)
+	$(call CHECK,\<989\>,minusNatural)
+	$(call CHECK,\<0\>,negateNatural)
+	$(call CHECK,\<1\>,signumNaturalP)
+	$(call CHECK,\<0\>,signumNaturalZ)
+	# Quotients and remainders
+	$(call CHECK2,\<813\>,\<60\>,quotRemNatural)
+	$(call CHECK2,\<219\>,\<196\>,divModNatural)
+	$(call CHECK,\<641\>,quotNatural)
+	$(call CHECK,\<68\>,remNatural)
+	$(call CHECK,\<642\>,divNatural)
+	$(call CHECK,\<90\>,modNatural)
+	$(call CHECK,\<50024\>,gcdNatural)
+	$(call CHECK,\<1001100300\>,lcmNatural)
+	# Conversions
+	$(call CHECK,\<200109\>,naturalFromInteger)
+	$(call CHECK,\<200113\>,naturalToInteger)
+	$(call CHECK,\<200145\>,wordToNatural)
+	$(call CHECK,\<200149\>,naturalToWord)
+	$(call CHECK,\<200153\>,intToNatural)
+	$(call CHECK,\<200157\>,naturalToInt)
+	$(call CHECK,\<200189.0\>,doubleFromNatural)
+	$(call CHECK,\<200193.0\>,floatFromNatural)
+	# Ordering and Equality
+	./naturalConstantFolding
diff --git a/testsuite/tests/lib/integer/all.T b/testsuite/tests/lib/integer/all.T
index f279be2f81..c132ca24dd 100644
--- a/testsuite/tests/lib/integer/all.T
+++ b/testsuite/tests/lib/integer/all.T
@@ -3,6 +3,7 @@ test('integerBits', normal, compile_and_run, [''])
 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'])
 test('IntegerConversionRules', [], makefile_test, ['IntegerConversionRules'])
 test('gcdInteger', normal, compile_and_run, [''])
diff --git a/testsuite/tests/lib/integer/naturalConstantFolding.hs b/testsuite/tests/lib/integer/naturalConstantFolding.hs
new file mode 100644
index 0000000000..9469d44bf6
--- /dev/null
+++ b/testsuite/tests/lib/integer/naturalConstantFolding.hs
@@ -0,0 +1,172 @@
+module Main (main) where
+
+import Data.Bits
+import Numeric.Natural (Natural)
+
+main :: IO ()
+main = do
+          p "andNatural"         andNatural
+          p "bitNatural"         bitNatural
+          p "minusNatural"       minusNatural
+          p "naturalFromInteger" naturalFromInteger
+          p "naturalToInteger"   naturalToInteger
+          p "negateNatural"      negateNatural
+          p "orNatural"          orNatural
+          p "plusNatural"        plusNatural
+          p "popCountNatural"    popCountNatural
+          p "divModNatural"      divModNatural
+          p "divNatural"         divNatural
+          p "modNatural"         modNatural
+          p "quotNatural"        quotNatural
+          p "quotRemNatural"     quotRemNatural
+          p "remNatural"         remNatural
+          p "gcdNatural"         gcdNatural
+          p "lcmNatural"         lcmNatural
+          p "shiftLNatural"      shiftLNatural
+          p "shiftRNatural"      shiftRNatural
+          p "signumNaturalP"     signumNaturalP
+          p "signumNaturalZ"     signumNaturalZ
+          p "testBitNaturalT"    testBitNaturalT
+          p "testBitNaturalF"    testBitNaturalF
+          p "timesNatural"       timesNatural
+          p "wordToNatural"      wordToNatural
+          p "naturalToWord"      naturalToWord
+          p "intToNatural"       intToNatural
+          p "naturalToInt"       naturalToInt
+          p "doubleFromNatural"  doubleFromNatural
+          p "floatFromNatural"   floatFromNatural
+          p "xorNatural"         xorNatural
+          p "eqNatural"          eqNatural
+          p "neqNatural"         neqNatural
+          p "leNatural"          leNatural
+          p "ltNatural"          ltNatural
+          p "geNatural"          geNatural
+          p "gtNatural"          gtNatural
+          p "compareNatural"     compareNatural
+
+  where p :: Show a => String -> a -> IO ()
+        p str x = putStrLn (str ++ ": " ++ show x)
+
+-- Bit arithmetic
+andNatural :: Natural
+andNatural = 100052 .&. 140053
+
+xorNatural :: Natural
+xorNatural = 100071 `xor` 140072
+
+bitNatural :: Natural
+bitNatural = bit 4
+
+orNatural :: Natural
+orNatural = 100058 .|. 140059
+
+shiftLNatural :: Natural
+shiftLNatural = 100065 `shiftL` 4
+
+shiftRNatural :: Natural
+shiftRNatural = 100066 `shiftR` 4
+
+popCountNatural :: Int
+popCountNatural = popCount (100098 :: Natural)
+
+testBitNaturalT :: Bool
+testBitNaturalT = testBit (100068 :: Natural) 2
+
+testBitNaturalF :: Bool
+testBitNaturalF = testBit (100069 :: Natural) 1
+-----------------------------------------------
+
+-- Arithmetic
+plusNatural :: Natural
+plusNatural = 100060 + 100061
+
+timesNatural :: Natural
+timesNatural = 100070 * 6832
+
+minusNatural :: Natural
+minusNatural = 100999 - 100010
+
+negateNatural :: Natural
+negateNatural = negate 0
+
+signumNaturalP :: Natural
+signumNaturalP = signum 100067
+
+signumNaturalZ :: Natural
+signumNaturalZ = signum 0
+------------------------
+
+-- Quotients and remainders
+quotRemNatural :: (Natural, Natural)
+quotRemNatural = 100063 `quotRem` 123
+
+divModNatural :: (Natural, Natural)
+divModNatural = 100060 `divMod` 456
+
+quotNatural :: Natural
+quotNatural = 100062 `quot` 156
+
+remNatural :: Natural
+remNatural = 100064 `rem` 156
+
+divNatural :: Natural
+divNatural = 100286 `div` 156
+
+modNatural :: Natural
+modNatural = 100086 `mod` 156
+
+gcdNatural :: Natural
+gcdNatural = 100048 `gcd` 150072
+
+lcmNatural :: Natural
+lcmNatural = 100050 `lcm` 100060
+--------------------------------
+
+-- Conversions
+naturalFromInteger :: Natural
+naturalFromInteger = fromInteger 100054 + 100055
+
+naturalToInteger :: Integer
+naturalToInteger = toInteger (100056 :: Natural) + 100057
+
+-- Same story as the @Integer@ case: for the conversion functions, we can't
+-- just check that e.g. 100065 is in the resulting core, because it will be
+-- regardless of whether the rules fire or not. So we add something to the
+-- number being converted, and thus rely on the addition rule for the
+-- end-result type also firing.
+wordToNatural :: Natural
+wordToNatural = fromIntegral (100072 :: Word) + 100073
+
+naturalToWord :: Word
+naturalToWord = 100075 + fromIntegral (100074 :: Natural)
+
+intToNatural :: Natural
+intToNatural = fromIntegral (100076 :: Int) + 100077
+
+naturalToInt :: Int
+naturalToInt = fromIntegral (100078 :: Natural) + 100079
+
+doubleFromNatural :: Double
+doubleFromNatural = 100095.0 + realToFrac (100094 :: Natural)
+
+floatFromNatural :: Float
+floatFromNatural = 100097.0 + realToFrac (100096 :: Natural)
+
+---------------------------------------------------
+
+-- Ordering and Equality
+eqNatural, neqNatural, leNatural, ltNatural, geNatural, gtNatural :: Bool
+eqNatural = (100080 :: Natural) == 100081
+
+neqNatural = (100082 :: Natural) /= 100083
+
+leNatural = (100084 :: Natural) <= 100085
+
+ltNatural = (100086 :: Natural) < 100087
+
+geNatural = (100088 :: Natural) >= 100089
+
+gtNatural = (100090 :: Natural) > 100091
+
+compareNatural :: Ordering
+compareNatural = compare (100092 :: Natural) 100093
diff --git a/testsuite/tests/lib/integer/naturalConstantFolding.stdout b/testsuite/tests/lib/integer/naturalConstantFolding.stdout
new file mode 100644
index 0000000000..3a8edda426
--- /dev/null
+++ b/testsuite/tests/lib/integer/naturalConstantFolding.stdout
@@ -0,0 +1,38 @@
+andNatural: 532
+bitNatural: 16
+minusNatural: 989
+naturalFromInteger: 200109
+naturalToInteger: 200113
+negateNatural: 0
+orNatural: 239579
+plusNatural: 200121
+popCountNatural: 6
+divModNatural: (219,196)
+divNatural: 642
+modNatural: 90
+quotNatural: 641
+quotRemNatural: (813,64)
+remNatural: 68
+gcdNatural: 50024
+lcmNatural: 1001100300
+shiftLNatural: 1601040
+shiftRNatural: 6254
+signumNaturalP: 1
+signumNaturalZ: 0
+testBitNaturalT: True
+testBitNaturalF: False
+timesNatural: 683678240
+wordToNatural: 200145
+naturalToWord: 200149
+intToNatural: 200153
+naturalToInt: 200157
+doubleFromNatural: 200189.0
+floatFromNatural: 200193.0
+xorNatural: 239055
+eqNatural: False
+neqNatural: True
+leNatural: True
+ltNatural: True
+geNatural: False
+gtNatural: False
+compareNatural: LT
diff --git a/testsuite/tests/simplCore/should_compile/T15445.stderr b/testsuite/tests/simplCore/should_compile/T15445.stderr
index bdeef2e1d8..3421b37072 100644
--- a/testsuite/tests/simplCore/should_compile/T15445.stderr
+++ b/testsuite/tests/simplCore/should_compile/T15445.stderr
@@ -1,6 +1,6 @@
 Rule fired: Class op + (BUILTIN)
 Rule fired: Class op fromInteger (BUILTIN)
-Rule fired: Integer -> Int# (BUILTIN)
+Rule fired: Integer -> Int# (wrap) (BUILTIN)
 Rule fired: SPEC plusTwoRec (T15445a)
 Rule fired: SPEC $fShow[] (GHC.Show)
 Rule fired: Class op >> (BUILTIN)