Commit bc5de347 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot
Browse files

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
parent 70dc2f09
......@@ -379,7 +379,6 @@ basicKnownKeyNames
integerToDoubleName,
integerEncodeFloatName,
integerEncodeDoubleName,
integerDecodeDoubleName,
integerGcdName,
integerLcmName,
integerAndName,
......@@ -397,7 +396,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
......@@ -2465,7 +2461,6 @@ integerFromNaturalIdKey
, integerFromWordIdKey
, integerFromWord64IdKey
, integerFromInt64IdKey
, integerDecodeDoubleIdKey
, naturalToWordIdKey
, naturalAddIdKey
, naturalSubIdKey
......@@ -2517,7 +2512,6 @@ integerShiftRIdKey = mkPreludeMiscIdUnique 637
integerFromWordIdKey = mkPreludeMiscIdUnique 638
integerFromWord64IdKey = mkPreludeMiscIdUnique 639
integerFromInt64IdKey = mkPreludeMiscIdUnique 640
integerDecodeDoubleIdKey = mkPreludeMiscIdUnique 641
naturalToWordIdKey = mkPreludeMiscIdUnique 650
naturalAddIdKey = mkPreludeMiscIdUnique 651
......
......@@ -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
......@@ -244,32 +243,34 @@ primOpRules nm = \case
DoubleToFloatOp -> mkPrimOpRule nm 1 [ liftLit doubleToFloatLit ]
-- 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
......@@ -514,6 +515,15 @@ floatOp2 op env (LitFloat f1) (LitFloat f2)
= Just (mkFloatVal env (f1 `op` 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
......@@ -522,6 +532,22 @@ doubleOp2 op env (LitDouble f1) (LitDouble f2)
= Just (mkDoubleVal env (f1 `op` 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1336,7 +1362,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
......@@ -1411,9 +1436,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 }
......@@ -1747,22 +1769,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
......
......@@ -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# #-}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment