Inline `integerDecodeDouble#` and constant-fold `decodeDouble_Int64#` instead

Currently, `integerDecodeDouble#` is known-key so that it can be
recognised in constant folding. But that is very brittle and doesn't
survive worker/wrapper, which we even do for
`NOINLINE` things since #13143.
Also it is a trade-off: The implementation of `integerDecodeDouble#`
allocates an `Integer` box that never cancels aways if we don't inline
it.

Hence we recognise the `decodeDouble_Int64#` primop instead in constant
folding, so that we can inline `integerDecodeDouble#`. As a result,
`integerDecodeDouble#` no longer needs to be known-key.

While doing so, I realised that we don't constant-fold
`decodeFloat_Int#` either, so I also added a RULE for it.

`integerDecodeDouble` is dead, so I deleted it.

Part of #18092. This improves the 32-bit `realToFrac`/`toRational`:

Metric Decrease:
    T10359

Cherry-picked from bc5de347bccd7a2691a9e4b927ab80acb7e15991

3 files changed, 52 insertions, 56 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 85f8cfbb2d..a1f8657a7b 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -378,7 +378,6 @@ basicKnownKeyNames
         integerToDoubleName,
         integerEncodeFloatName,
         integerEncodeDoubleName,
-        integerDecodeDoubleName,
         integerGcdName,
         integerLcmName,
         integerAndName,
@@ -396,7 +395,6 @@ basicKnownKeyNames
         naturalRemName,
         naturalQuotRemName,
         bignatFromWordListName,
-
         -- Float/Double
         rationalToFloatName,
         rationalToDoubleName,
@@ -1154,7 +1152,6 @@ integerFromNaturalName
    , integerToDoubleName
    , integerEncodeFloatName
    , integerEncodeDoubleName
-   , integerDecodeDoubleName
    , integerGcdName
    , integerLcmName
    , integerAndName
@@ -1222,7 +1219,6 @@ integerToFloatName        = bniVarQual "integerToFloat#"           integerToFloa
 integerToDoubleName       = bniVarQual "integerToDouble#"          integerToDoubleIdKey
 integerEncodeFloatName    = bniVarQual "integerEncodeFloat#"       integerEncodeFloatIdKey
 integerEncodeDoubleName   = bniVarQual "integerEncodeDouble#"      integerEncodeDoubleIdKey
-integerDecodeDoubleName   = bniVarQual "integerDecodeDouble#"      integerDecodeDoubleIdKey
 integerGcdName            = bniVarQual "integerGcd"                integerGcdIdKey
 integerLcmName            = bniVarQual "integerLcm"                integerLcmIdKey
 integerAndName            = bniVarQual "integerAnd"                integerAndIdKey
@@ -2466,7 +2462,6 @@ integerFromNaturalIdKey
    , integerFromWordIdKey
    , integerFromWord64IdKey
    , integerFromInt64IdKey
-   , integerDecodeDoubleIdKey
    , naturalToWordIdKey
    , naturalAddIdKey
    , naturalSubIdKey
@@ -2518,7 +2513,6 @@ integerShiftRIdKey         = mkPreludeMiscIdUnique 637
 integerFromWordIdKey       = mkPreludeMiscIdUnique 638
 integerFromWord64IdKey     = mkPreludeMiscIdUnique 639
 integerFromInt64IdKey      = mkPreludeMiscIdUnique 640
-integerDecodeDoubleIdKey   = 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 3e0932bb50..dada75cc1b 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -13,8 +13,7 @@ ToDo:
 -}
 
 {-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards,
-    DeriveFunctor #-}
-{-# LANGUAGE LambdaCase #-}
+    DeriveFunctor, LambdaCase, TypeApplications #-}
 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}
 
 module GHC.Core.Opt.ConstantFold
@@ -241,32 +240,34 @@ primOpRules nm = \case
    Double2FloatOp -> mkPrimOpRule nm 1 [ liftLit double2FloatLit ]
 
    -- Float
-   FloatAddOp   -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
-                                     , identity zerof ]
-   FloatSubOp   -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
-                                     , rightIdentity zerof ]
-   FloatMulOp   -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
-                                     , identity onef
-                                     , strengthReduction twof FloatAddOp  ]
+   FloatAddOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
+                                          , identity zerof ]
+   FloatSubOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
+                                          , rightIdentity zerof ]
+   FloatMulOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
+                                          , identity onef
+                                          , strengthReduction twof FloatAddOp  ]
              -- zeroElem zerof doesn't hold because of NaN
-   FloatDivOp   -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
-                                     , rightIdentity onef ]
-   FloatNegOp   -> mkPrimOpRule nm 1 [ unaryLit negOp
-                                     , inversePrimOp FloatNegOp ]
+   FloatDivOp        -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
+                                          , rightIdentity onef ]
+   FloatNegOp        -> mkPrimOpRule nm 1 [ unaryLit negOp
+                                          , inversePrimOp FloatNegOp ]
+   FloatDecode_IntOp -> mkPrimOpRule nm 1 [ unaryLit floatDecodeOp ]
 
    -- Double
-   DoubleAddOp   -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
-                                      , identity zerod ]
-   DoubleSubOp   -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
-                                      , rightIdentity zerod ]
-   DoubleMulOp   -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
-                                      , identity oned
-                                      , strengthReduction twod DoubleAddOp  ]
+   DoubleAddOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
+                                             , identity zerod ]
+   DoubleSubOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
+                                             , rightIdentity zerod ]
+   DoubleMulOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
+                                             , identity oned
+                                             , strengthReduction twod DoubleAddOp  ]
               -- zeroElem zerod doesn't hold because of NaN
-   DoubleDivOp   -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
-                                      , rightIdentity oned ]
-   DoubleNegOp   -> mkPrimOpRule nm 1 [ unaryLit negOp
-                                      , inversePrimOp DoubleNegOp ]
+   DoubleDivOp          -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
+                                             , rightIdentity oned ]
+   DoubleNegOp          -> mkPrimOpRule nm 1 [ unaryLit negOp
+                                             , inversePrimOp DoubleNegOp ]
+   DoubleDecode_Int64Op -> mkPrimOpRule nm 1 [ unaryLit doubleDecodeOp ]
 
    -- Relational operators
 
@@ -512,6 +513,15 @@ floatOp2 op env (LitFloat f1) (LitFloat f2)
 floatOp2 _ _ _ _ = Nothing
 
 --------------------------
+floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr
+floatDecodeOp env (LitFloat ((decodeFloat . fromRational @Float) -> (m, e)))
+  = Just $ mkCoreUbxTup [intPrimTy, intPrimTy]
+                        [ mkIntVal (roPlatform env) (toInteger m)
+                        , mkIntVal (roPlatform env) (toInteger e) ]
+floatDecodeOp _   _
+  = Nothing
+
+--------------------------
 doubleOp2 :: (Rational -> Rational -> Rational)
           -> RuleOpts -> Literal -> Literal
           -> Maybe (Expr CoreBndr)
@@ -520,6 +530,22 @@ doubleOp2 op env (LitDouble f1) (LitDouble f2)
 doubleOp2 _ _ _ _ = Nothing
 
 --------------------------
+doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr
+doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e)))
+  = Just $ mkCoreUbxTup [iNT64Ty, intPrimTy]
+                        [ Lit (mkLitINT64 (roPlatform env) (toInteger m))
+                        , mkIntVal platform (toInteger e) ]
+  where
+    platform = roPlatform env
+    (iNT64Ty, mkLitINT64)
+      | platformWordSizeInBits platform < 64
+      = (int64PrimTy, mkLitInt64Wrap)
+      | otherwise
+      = (intPrimTy  , mkLitIntWrap)
+doubleDecodeOp _   _
+  = Nothing
+
+--------------------------
 {- Note [The litEq rule: converting equality to case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 This stuff turns
@@ -1333,7 +1359,6 @@ builtinBignumRules _ =
       , rule_encodeFloat        "integerEncodeFloat"  integerEncodeFloatName  mkFloatLitFloat
       , rule_convert            "integerToFloat"      integerToFloatName      (\_ -> mkFloatLitFloat)
       , rule_encodeFloat        "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble
-      , rule_decodeDouble       "integerDecodeDouble" integerDecodeDoubleName
       , rule_convert            "integerToDouble"     integerToDoubleName     (\_ -> mkDoubleLitDouble)
       , rule_binopi             "integerGcd"          integerGcdName          gcd
       , rule_binopi             "integerLcm"          integerLcmName          lcm
@@ -1408,9 +1433,6 @@ builtinBignumRules _ =
           rule_encodeFloat str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_Int_encodeFloat op }
-          rule_decodeDouble str name
-           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
-                           ru_try = match_decodeDouble }
           rule_passthrough str name toIntegerName
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
                            ru_try = match_passthrough toIntegerName }
@@ -1744,22 +1766,6 @@ match_rationalTo mkLit _ id_unf _ [xl, yl]
   = Just (mkLit (fromRational (x % y)))
 match_rationalTo _ _ _ _ _ = Nothing
 
-match_decodeDouble :: RuleFun
-match_decodeDouble env id_unf fn [xl]
-  | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl
-  = case splitFunTy_maybe (idType fn) of
-    Just (_, _, res)
-      | Just [_lev1, _lev2, _integerTy, intHashTy] <- tyConAppArgs_maybe res
-      -> case decodeFloat (fromRational x :: Double) of
-           (y, z) ->
-             Just $ mkCoreUbxTup [integerTy, intHashTy]
-                                 [Lit (mkLitInteger y),
-                                  Lit (mkLitInt (roPlatform env) (toInteger z))]
-    _ ->
-        pprPanic "match_decodeDouble: Id has the wrong type"
-          (ppr fn <+> dcolon <+> ppr (idType fn))
-match_decodeDouble _ _ _ _ = Nothing
-
 match_passthrough :: Name -> RuleFun
 match_passthrough n _ _ _ [App (Var x) y]
   | idName x == n
diff --git a/libraries/ghc-bignum/src/GHC/Num/Integer.hs b/libraries/ghc-bignum/src/GHC/Num/Integer.hs
index 554335eba5..fb9f4a81d5 100644
--- a/libraries/ghc-bignum/src/GHC/Num/Integer.hs
+++ b/libraries/ghc-bignum/src/GHC/Num/Integer.hs
@@ -1048,15 +1048,11 @@ integerFromInt64# !x = IS x
 
 -- | Decode a Double# into (# Integer mantissa, Int# exponent #)
 integerDecodeDouble# :: Double# -> (# Integer, Int# #)
-{-# NOINLINE integerDecodeDouble# #-}
+{-# INLINE integerDecodeDouble# #-} -- decodeDouble_Int64# is constant-folded
+                                    -- in GHC.Core.Opt.ConstantFold
 integerDecodeDouble# !x = case decodeDouble_Int64# x of
                             (# m, e #) -> (# integerFromInt64# m, e #)
 
--- | Decode a Double# into (# Integer mantissa, Int# exponent #)
-integerDecodeDouble :: Double -> (Integer, Int)
-integerDecodeDouble (D# x) = case integerDecodeDouble# x of
-   (# m, e #) -> (m, I# e)
-
 -- | Encode (# Integer mantissa, Int# exponent #) into a Double#
 integerEncodeDouble# :: Integer -> Int# -> Double#
 {-# NOINLINE integerEncodeDouble# #-}