Bignum: fix for Integer/Natural Ord instances

* allow `integerCompare` to inline into `integerLe#`, etc.
* use `naturalSubThrow` to implement Natural's `(-)`
* use `naturalNegate` to implement Natural's `negate`
* implement and use `integerToNaturalThrow` to implement Natural's `fromInteger`

Thanks to @christiaanb for reporting these

5 files changed, 105 insertions, 84 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 5cf4753a45..953d1edbd0 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -349,6 +349,7 @@ basicKnownKeyNames
         -- ghc-bignum
         integerFromNaturalName,
         integerToNaturalClampName,
+        integerToNaturalThrowName,
         integerToWordName,
         integerToIntName,
         integerToWord64Name,
@@ -1122,6 +1123,7 @@ negateName        = varQual gHC_NUM (fsLit "negate")      negateClassOpKey
 ---------------------------------
 integerFromNaturalName
    , integerToNaturalClampName
+   , integerToNaturalThrowName
    , integerToWordName
    , integerToIntName
    , integerToWord64Name
@@ -1189,6 +1191,7 @@ naturalQuotRemName        = bnnVarQual "naturalQuotRem"            naturalQuotRe
 
 integerFromNaturalName    = bniVarQual "integerFromNatural"        integerFromNaturalIdKey
 integerToNaturalClampName = bniVarQual "integerToNaturalClamp"     integerToNaturalClampIdKey
+integerToNaturalThrowName = bniVarQual "integerToNaturalThrow"     integerToNaturalThrowIdKey
 integerToWordName         = bniVarQual "integerToWord#"            integerToWordIdKey
 integerToIntName          = bniVarQual "integerToInt#"             integerToIntIdKey
 integerToWord64Name       = bniVarQual "integerToWord64#"          integerToWord64IdKey
@@ -2422,6 +2425,7 @@ unsafeCoercePrimIdKey    = mkPreludeMiscIdUnique 571
 
 integerFromNaturalIdKey
    , integerToNaturalClampIdKey
+   , integerToNaturalThrowIdKey
    , integerToWordIdKey
    , integerToIntIdKey
    , integerToWord64IdKey
@@ -2473,45 +2477,46 @@ integerFromNaturalIdKey
 
 integerFromNaturalIdKey    = mkPreludeMiscIdUnique 600
 integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601
-integerToWordIdKey         = mkPreludeMiscIdUnique 602
-integerToIntIdKey          = mkPreludeMiscIdUnique 603
-integerToWord64IdKey       = mkPreludeMiscIdUnique 604
-integerToInt64IdKey        = mkPreludeMiscIdUnique 605
-integerAddIdKey            = mkPreludeMiscIdUnique 606
-integerMulIdKey            = mkPreludeMiscIdUnique 607
-integerSubIdKey            = mkPreludeMiscIdUnique 608
-integerNegateIdKey         = mkPreludeMiscIdUnique 609
-integerEqPrimIdKey         = mkPreludeMiscIdUnique 610
-integerNePrimIdKey         = mkPreludeMiscIdUnique 611
-integerLePrimIdKey         = mkPreludeMiscIdUnique 612
-integerGtPrimIdKey         = mkPreludeMiscIdUnique 613
-integerLtPrimIdKey         = mkPreludeMiscIdUnique 614
-integerGePrimIdKey         = mkPreludeMiscIdUnique 615
-integerAbsIdKey            = mkPreludeMiscIdUnique 616
-integerSignumIdKey         = mkPreludeMiscIdUnique 617
-integerCompareIdKey        = mkPreludeMiscIdUnique 618
-integerQuotIdKey           = mkPreludeMiscIdUnique 619
-integerRemIdKey            = mkPreludeMiscIdUnique 620
-integerDivIdKey            = mkPreludeMiscIdUnique 621
-integerModIdKey            = mkPreludeMiscIdUnique 622
-integerDivModIdKey         = mkPreludeMiscIdUnique 623
-integerQuotRemIdKey        = mkPreludeMiscIdUnique 624
-integerToFloatIdKey        = mkPreludeMiscIdUnique 625
-integerToDoubleIdKey       = mkPreludeMiscIdUnique 626
-integerEncodeFloatIdKey    = mkPreludeMiscIdUnique 627
-integerEncodeDoubleIdKey   = mkPreludeMiscIdUnique 628
-integerGcdIdKey            = mkPreludeMiscIdUnique 629
-integerLcmIdKey            = mkPreludeMiscIdUnique 630
-integerAndIdKey            = mkPreludeMiscIdUnique 631
-integerOrIdKey             = mkPreludeMiscIdUnique 632
-integerXorIdKey            = mkPreludeMiscIdUnique 633
-integerComplementIdKey     = mkPreludeMiscIdUnique 634
-integerBitIdKey            = mkPreludeMiscIdUnique 635
-integerShiftLIdKey         = mkPreludeMiscIdUnique 636
-integerShiftRIdKey         = mkPreludeMiscIdUnique 637
-integerFromWordIdKey       = mkPreludeMiscIdUnique 638
-integerFromWord64IdKey     = mkPreludeMiscIdUnique 639
-integerFromInt64IdKey      = mkPreludeMiscIdUnique 640
+integerToNaturalThrowIdKey = mkPreludeMiscIdUnique 602
+integerToWordIdKey         = mkPreludeMiscIdUnique 603
+integerToIntIdKey          = mkPreludeMiscIdUnique 604
+integerToWord64IdKey       = mkPreludeMiscIdUnique 605
+integerToInt64IdKey        = mkPreludeMiscIdUnique 606
+integerAddIdKey            = mkPreludeMiscIdUnique 607
+integerMulIdKey            = mkPreludeMiscIdUnique 608
+integerSubIdKey            = mkPreludeMiscIdUnique 609
+integerNegateIdKey         = mkPreludeMiscIdUnique 610
+integerEqPrimIdKey         = mkPreludeMiscIdUnique 611
+integerNePrimIdKey         = mkPreludeMiscIdUnique 612
+integerLePrimIdKey         = mkPreludeMiscIdUnique 613
+integerGtPrimIdKey         = mkPreludeMiscIdUnique 614
+integerLtPrimIdKey         = mkPreludeMiscIdUnique 615
+integerGePrimIdKey         = mkPreludeMiscIdUnique 616
+integerAbsIdKey            = mkPreludeMiscIdUnique 617
+integerSignumIdKey         = mkPreludeMiscIdUnique 618
+integerCompareIdKey        = mkPreludeMiscIdUnique 619
+integerQuotIdKey           = mkPreludeMiscIdUnique 620
+integerRemIdKey            = mkPreludeMiscIdUnique 621
+integerDivIdKey            = mkPreludeMiscIdUnique 622
+integerModIdKey            = mkPreludeMiscIdUnique 623
+integerDivModIdKey         = mkPreludeMiscIdUnique 624
+integerQuotRemIdKey        = mkPreludeMiscIdUnique 625
+integerToFloatIdKey        = mkPreludeMiscIdUnique 626
+integerToDoubleIdKey       = mkPreludeMiscIdUnique 627
+integerEncodeFloatIdKey    = mkPreludeMiscIdUnique 628
+integerEncodeDoubleIdKey   = mkPreludeMiscIdUnique 629
+integerGcdIdKey            = mkPreludeMiscIdUnique 630
+integerLcmIdKey            = mkPreludeMiscIdUnique 631
+integerAndIdKey            = mkPreludeMiscIdUnique 632
+integerOrIdKey             = mkPreludeMiscIdUnique 633
+integerXorIdKey            = mkPreludeMiscIdUnique 634
+integerComplementIdKey     = mkPreludeMiscIdUnique 635
+integerBitIdKey            = mkPreludeMiscIdUnique 636
+integerShiftLIdKey         = mkPreludeMiscIdUnique 637
+integerShiftRIdKey         = mkPreludeMiscIdUnique 638
+integerFromWordIdKey       = mkPreludeMiscIdUnique 639
+integerFromWord64IdKey     = mkPreludeMiscIdUnique 640
+integerFromInt64IdKey      = mkPreludeMiscIdUnique 641
 
 naturalToWordIdKey         = mkPreludeMiscIdUnique 650
 naturalAddIdKey            = mkPreludeMiscIdUnique 651
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 948914e92a..d6d8ee906a 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -1432,6 +1432,7 @@ builtinBignumRules _ =
       , rule_passthrough      "Word# -> Natural -> Word#"       naturalToWordName   naturalNSDataConName
 
       , rule_IntegerToNaturalClamp "Integer -> Natural (clamp)" integerToNaturalClampName
+      , rule_IntegerToNaturalThrow "Integer -> Natural (throw)" integerToNaturalThrowName
       , rule_binopn             "naturalAdd"          naturalAddName       (+)
       , rule_partial_binopn     "naturalSub"          naturalSubName       (\a b -> if a >= b then Just (a - b) else Nothing)
       , rule_binopn             "naturalMul"          naturalMulName       (*)
@@ -1485,6 +1486,9 @@ builtinBignumRules _ =
           rule_IntegerToNaturalClamp str name
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
                            ru_try = match_IntegerToNaturalClamp }
+          rule_IntegerToNaturalThrow str name
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_IntegerToNaturalThrow }
           rule_binopn str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Natural_binop op }
@@ -1657,6 +1661,14 @@ match_IntegerToNaturalClamp _ id_unf _ [xl]
       else Just (Lit (mkLitNatural 0))
 match_IntegerToNaturalClamp _ _ _ _ = Nothing
 
+match_IntegerToNaturalThrow :: RuleFun
+match_IntegerToNaturalThrow _ id_unf _ [xl]
+  | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl
+  = if x >= 0
+      then Just (Lit (mkLitNatural x))
+      else Nothing
+match_IntegerToNaturalThrow _ _ _ _ = Nothing
+
 -------------------------------------------------
 {- Note [Rewriting integerBit]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/libraries/base/GHC/Num.hs b/libraries/base/GHC/Num.hs
index f80f431361..df0c66b7bd 100644
--- a/libraries/base/GHC/Num.hs
+++ b/libraries/base/GHC/Num.hs
@@ -35,7 +35,6 @@ import qualified GHC.Integer
 import GHC.Base
 import GHC.Num.Integer
 import GHC.Num.Natural
-import {-# SOURCE #-} GHC.Exception.Type
 
 infixl 7  *
 infixl 6  +, -
@@ -140,20 +139,10 @@ instance  Num Integer  where
 -- @since 4.8.0.0
 instance  Num Natural  where
     (+) = naturalAdd
-    (-) x y = case compare x y of
-      EQ -> naturalZero
-      GT -> naturalSubUnsafe x y
-      LT -> raise# underflowException
-
+    (-) = naturalSubThrow
     (*) = naturalMul
-    negate x
-      | naturalIsZero x = x
-      | otherwise       = raise# underflowException
-
-    fromInteger x
-      | x < 0     = raise# underflowException
-      | otherwise = integerToNaturalClamp x
-
+    negate = naturalNegate
+    fromInteger = integerToNaturalThrow
     abs    = id
     signum = naturalSignum
 
diff --git a/libraries/ghc-bignum/src/GHC/Num/Integer.hs b/libraries/ghc-bignum/src/GHC/Num/Integer.hs
index 870ac745ea..2e0327127d 100644
--- a/libraries/ghc-bignum/src/GHC/Num/Integer.hs
+++ b/libraries/ghc-bignum/src/GHC/Num/Integer.hs
@@ -225,6 +225,17 @@ integerToNatural (IS x) = naturalFromWord# (wordFromAbsInt# x)
 integerToNatural (IP x) = naturalFromBigNat# x
 integerToNatural (IN x) = naturalFromBigNat# x
 
+-- | Convert a Integer into a Natural
+--
+-- Throw on underflow
+integerToNaturalThrow :: Integer -> Natural
+{-# NOINLINE integerToNaturalThrow #-}
+integerToNaturalThrow (IS x)
+  | isTrue# (x <# 0#) = raiseUnderflow
+  | True              = naturalFromWord# (int2Word# x)
+integerToNaturalThrow (IP x) = naturalFromBigNat# x
+integerToNaturalThrow (IN _) = raiseUnderflow
+
 ---------------------------------------------------------------------
 -- Predicates
 ---------------------------------------------------------------------
@@ -292,30 +303,30 @@ integerNe# _       _     = 1#
 -- | Greater predicate.
 integerGt# :: Integer -> Integer -> Bool#
 {-# NOINLINE integerGt# #-}
-integerGt# (IS x) (IS y)                  = x ># y
-integerGt# x y | GT <- integerCompare x y = 1#
-integerGt# _ _                            = 0#
+integerGt# (IS x) (IS y)                   = x ># y
+integerGt# x y | GT <- integerCompare' x y = 1#
+integerGt# _ _                             = 0#
 
 -- | Lower-or-equal predicate.
 integerLe# :: Integer -> Integer -> Bool#
 {-# NOINLINE integerLe# #-}
-integerLe# (IS x) (IS y)                  = x <=# y
-integerLe# x y | GT <- integerCompare x y = 0#
-integerLe# _ _                            = 1#
+integerLe# (IS x) (IS y)                   = x <=# y
+integerLe# x y | GT <- integerCompare' x y = 0#
+integerLe# _ _                             = 1#
 
 -- | Lower predicate.
 integerLt# :: Integer -> Integer -> Bool#
 {-# NOINLINE integerLt# #-}
-integerLt# (IS x) (IS y)                  = x <# y
-integerLt# x y | LT <- integerCompare x y = 1#
-integerLt# _ _                            = 0#
+integerLt# (IS x) (IS y)                   = x <# y
+integerLt# x y | LT <- integerCompare' x y = 1#
+integerLt# _ _                             = 0#
 
 -- | Greater-or-equal predicate.
 integerGe# :: Integer -> Integer -> Bool#
 {-# NOINLINE integerGe# #-}
-integerGe# (IS x) (IS y)                  = x >=# y
-integerGe# x y | LT <- integerCompare x y = 0#
-integerGe# _ _                            = 1#
+integerGe# (IS x) (IS y)                   = x >=# y
+integerGe# x y | LT <- integerCompare' x y = 0#
+integerGe# _ _                             = 1#
 
 instance Eq Integer where
    (==) = integerEq
@@ -324,18 +335,26 @@ instance Eq Integer where
 -- | Compare two Integer
 integerCompare :: Integer -> Integer -> Ordering
 {-# NOINLINE integerCompare #-}
-integerCompare (IS x) (IS y) = compareInt# x y
-integerCompare (IP x) (IP y) = bigNatCompare x y
-integerCompare (IN x) (IN y) = bigNatCompare y x
-integerCompare (IS _) (IP _) = LT
-integerCompare (IS _) (IN _) = GT
-integerCompare (IP _) (IS _) = GT
-integerCompare (IN _) (IS _) = LT
-integerCompare (IP _) (IN _) = GT
-integerCompare (IN _) (IP _) = LT
+integerCompare = integerCompare'
+
+integerCompare' :: Integer -> Integer -> Ordering
+{-# INLINE integerCompare' #-}
+integerCompare' (IS x) (IS y) = compareInt# x y
+integerCompare' (IP x) (IP y) = bigNatCompare x y
+integerCompare' (IN x) (IN y) = bigNatCompare y x
+integerCompare' (IS _) (IP _) = LT
+integerCompare' (IS _) (IN _) = GT
+integerCompare' (IP _) (IS _) = GT
+integerCompare' (IN _) (IS _) = LT
+integerCompare' (IP _) (IN _) = GT
+integerCompare' (IN _) (IP _) = LT
 
 instance Ord Integer where
    compare = integerCompare
+   (<)     = integerLt
+   (<=)    = integerLe
+   (>)     = integerGt
+   (>=)    = integerGe
 
 ---------------------------------------------------------------------
 -- Operations
diff --git a/testsuite/tests/numeric/should_compile/T14465.stdout b/testsuite/tests/numeric/should_compile/T14465.stdout
index d9287fcd32..b493cee119 100644
--- a/testsuite/tests/numeric/should_compile/T14465.stdout
+++ b/testsuite/tests/numeric/should_compile/T14465.stdout
@@ -1,7 +1,7 @@
 
 ==================== Tidy Core ====================
 Result size of Tidy Core
-  = {terms: 40, types: 17, coercions: 0, joins: 0/0}
+  = {terms: 35, types: 14, coercions: 0, joins: 0/0}
 
 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
 ten :: Natural
@@ -52,19 +52,15 @@ M.minusOne1 :: Natural
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}]
 M.minusOne1 = 1
 
--- RHS size: {terms: 11, types: 4, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 6, types: 1, coercions: 0, joins: 0/0}
 minusOne :: Natural
 [GblId,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
-         WorkFree=True, Expandable=False, Guidance=IF_ARGS [] 40 0}]
+         WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 40 10}]
 minusOne
-  = case M.minusOne1 of wild {
-      NS ds1 ->
-        case ds1 of {
-          __DEFAULT -> GHC.Num.$fNumNatural1;
-          0## -> wild
-        };
-      NB ipv -> GHC.Num.$fNumNatural1
+  = case GHC.Num.Natural.$wnaturalNegate M.minusOne1 of ww
+    { __DEFAULT ->
+    GHC.Num.Natural.NS ww
     }
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}