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 ...@@ -379,7 +379,6 @@ basicKnownKeyNames
integerToDoubleName, integerToDoubleName,
integerEncodeFloatName, integerEncodeFloatName,
integerEncodeDoubleName, integerEncodeDoubleName,
integerDecodeDoubleName,
integerGcdName, integerGcdName,
integerLcmName, integerLcmName,
integerAndName, integerAndName,
...@@ -397,7 +396,6 @@ basicKnownKeyNames ...@@ -397,7 +396,6 @@ basicKnownKeyNames
naturalRemName, naturalRemName,
naturalQuotRemName, naturalQuotRemName,
bignatFromWordListName, bignatFromWordListName,
-- Float/Double -- Float/Double
rationalToFloatName, rationalToFloatName,
rationalToDoubleName, rationalToDoubleName,
...@@ -1154,7 +1152,6 @@ integerFromNaturalName ...@@ -1154,7 +1152,6 @@ integerFromNaturalName
, integerToDoubleName , integerToDoubleName
, integerEncodeFloatName , integerEncodeFloatName
, integerEncodeDoubleName , integerEncodeDoubleName
, integerDecodeDoubleName
, integerGcdName , integerGcdName
, integerLcmName , integerLcmName
, integerAndName , integerAndName
...@@ -1222,7 +1219,6 @@ integerToFloatName = bniVarQual "integerToFloat#" integerToFloa ...@@ -1222,7 +1219,6 @@ integerToFloatName = bniVarQual "integerToFloat#" integerToFloa
integerToDoubleName = bniVarQual "integerToDouble#" integerToDoubleIdKey integerToDoubleName = bniVarQual "integerToDouble#" integerToDoubleIdKey
integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey
integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey
integerDecodeDoubleName = bniVarQual "integerDecodeDouble#" integerDecodeDoubleIdKey
integerGcdName = bniVarQual "integerGcd" integerGcdIdKey integerGcdName = bniVarQual "integerGcd" integerGcdIdKey
integerLcmName = bniVarQual "integerLcm" integerLcmIdKey integerLcmName = bniVarQual "integerLcm" integerLcmIdKey
integerAndName = bniVarQual "integerAnd" integerAndIdKey integerAndName = bniVarQual "integerAnd" integerAndIdKey
...@@ -2465,7 +2461,6 @@ integerFromNaturalIdKey ...@@ -2465,7 +2461,6 @@ integerFromNaturalIdKey
, integerFromWordIdKey , integerFromWordIdKey
, integerFromWord64IdKey , integerFromWord64IdKey
, integerFromInt64IdKey , integerFromInt64IdKey
, integerDecodeDoubleIdKey
, naturalToWordIdKey , naturalToWordIdKey
, naturalAddIdKey , naturalAddIdKey
, naturalSubIdKey , naturalSubIdKey
...@@ -2517,7 +2512,6 @@ integerShiftRIdKey = mkPreludeMiscIdUnique 637 ...@@ -2517,7 +2512,6 @@ integerShiftRIdKey = mkPreludeMiscIdUnique 637
integerFromWordIdKey = mkPreludeMiscIdUnique 638 integerFromWordIdKey = mkPreludeMiscIdUnique 638
integerFromWord64IdKey = mkPreludeMiscIdUnique 639 integerFromWord64IdKey = mkPreludeMiscIdUnique 639
integerFromInt64IdKey = mkPreludeMiscIdUnique 640 integerFromInt64IdKey = mkPreludeMiscIdUnique 640
integerDecodeDoubleIdKey = mkPreludeMiscIdUnique 641
naturalToWordIdKey = mkPreludeMiscIdUnique 650 naturalToWordIdKey = mkPreludeMiscIdUnique 650
naturalAddIdKey = mkPreludeMiscIdUnique 651 naturalAddIdKey = mkPreludeMiscIdUnique 651
......
...@@ -13,8 +13,7 @@ ToDo: ...@@ -13,8 +13,7 @@ ToDo:
-} -}
{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards, {-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards,
DeriveFunctor #-} DeriveFunctor, LambdaCase, TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.ConstantFold module GHC.Core.Opt.ConstantFold
...@@ -244,32 +243,34 @@ primOpRules nm = \case ...@@ -244,32 +243,34 @@ primOpRules nm = \case
DoubleToFloatOp -> mkPrimOpRule nm 1 [ liftLit doubleToFloatLit ] DoubleToFloatOp -> mkPrimOpRule nm 1 [ liftLit doubleToFloatLit ]
-- Float -- Float
FloatAddOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) FloatAddOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
, identity zerof ] , identity zerof ]
FloatSubOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) FloatSubOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
, rightIdentity zerof ] , rightIdentity zerof ]
FloatMulOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) FloatMulOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
, identity onef , identity onef
, strengthReduction twof FloatAddOp ] , strengthReduction twof FloatAddOp ]
-- zeroElem zerof doesn't hold because of NaN -- zeroElem zerof doesn't hold because of NaN
FloatDivOp -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) FloatDivOp -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
, rightIdentity onef ] , rightIdentity onef ]
FloatNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp FloatNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp
, inversePrimOp FloatNegOp ] , inversePrimOp FloatNegOp ]
FloatDecode_IntOp -> mkPrimOpRule nm 1 [ unaryLit floatDecodeOp ]
-- Double -- Double
DoubleAddOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) DoubleAddOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
, identity zerod ] , identity zerod ]
DoubleSubOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) DoubleSubOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
, rightIdentity zerod ] , rightIdentity zerod ]
DoubleMulOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) DoubleMulOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
, identity oned , identity oned
, strengthReduction twod DoubleAddOp ] , strengthReduction twod DoubleAddOp ]
-- zeroElem zerod doesn't hold because of NaN -- zeroElem zerod doesn't hold because of NaN
DoubleDivOp -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) DoubleDivOp -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
, rightIdentity oned ] , rightIdentity oned ]
DoubleNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp DoubleNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp
, inversePrimOp DoubleNegOp ] , inversePrimOp DoubleNegOp ]
DoubleDecode_Int64Op -> mkPrimOpRule nm 1 [ unaryLit doubleDecodeOp ]
-- Relational operators -- Relational operators
...@@ -514,6 +515,15 @@ floatOp2 op env (LitFloat f1) (LitFloat f2) ...@@ -514,6 +515,15 @@ floatOp2 op env (LitFloat f1) (LitFloat f2)
= Just (mkFloatVal env (f1 `op` f2)) = Just (mkFloatVal env (f1 `op` f2))
floatOp2 _ _ _ _ = Nothing 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) doubleOp2 :: (Rational -> Rational -> Rational)
-> RuleOpts -> Literal -> Literal -> RuleOpts -> Literal -> Literal
...@@ -522,6 +532,22 @@ doubleOp2 op env (LitDouble f1) (LitDouble f2) ...@@ -522,6 +532,22 @@ doubleOp2 op env (LitDouble f1) (LitDouble f2)
= Just (mkDoubleVal env (f1 `op` f2)) = Just (mkDoubleVal env (f1 `op` f2))
doubleOp2 _ _ _ _ = Nothing 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] {- Note [The litEq rule: converting equality to case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -1336,7 +1362,6 @@ builtinBignumRules _ = ...@@ -1336,7 +1362,6 @@ builtinBignumRules _ =
, rule_encodeFloat "integerEncodeFloat" integerEncodeFloatName mkFloatLitFloat , rule_encodeFloat "integerEncodeFloat" integerEncodeFloatName mkFloatLitFloat
, rule_convert "integerToFloat" integerToFloatName (\_ -> mkFloatLitFloat) , rule_convert "integerToFloat" integerToFloatName (\_ -> mkFloatLitFloat)
, rule_encodeFloat "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble , rule_encodeFloat "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble
, rule_decodeDouble "integerDecodeDouble" integerDecodeDoubleName
, rule_convert "integerToDouble" integerToDoubleName (\_ -> mkDoubleLitDouble) , rule_convert "integerToDouble" integerToDoubleName (\_ -> mkDoubleLitDouble)
, rule_binopi "integerGcd" integerGcdName gcd , rule_binopi "integerGcd" integerGcdName gcd
, rule_binopi "integerLcm" integerLcmName lcm , rule_binopi "integerLcm" integerLcmName lcm
...@@ -1411,9 +1436,6 @@ builtinBignumRules _ = ...@@ -1411,9 +1436,6 @@ builtinBignumRules _ =
rule_encodeFloat str name op rule_encodeFloat str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_Int_encodeFloat op } 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 rule_passthrough str name toIntegerName
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_passthrough toIntegerName } ru_try = match_passthrough toIntegerName }
...@@ -1747,22 +1769,6 @@ match_rationalTo mkLit _ id_unf _ [xl, yl] ...@@ -1747,22 +1769,6 @@ match_rationalTo mkLit _ id_unf _ [xl, yl]
= Just (mkLit (fromRational (x % y))) = Just (mkLit (fromRational (x % y)))
match_rationalTo _ _ _ _ _ = Nothing 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 :: Name -> RuleFun
match_passthrough n _ _ _ [App (Var x) y] match_passthrough n _ _ _ [App (Var x) y]
| idName x == n | idName x == n
......
...@@ -1048,15 +1048,11 @@ integerFromInt64# !x = IS x ...@@ -1048,15 +1048,11 @@ integerFromInt64# !x = IS x
-- | Decode a Double# into (# Integer mantissa, Int# exponent #) -- | Decode a Double# into (# Integer mantissa, Int# exponent #)
integerDecodeDouble# :: Double# -> (# Integer, Int# #) 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 integerDecodeDouble# !x = case decodeDouble_Int64# x of
(# m, e #) -> (# integerFromInt64# m, e #) (# 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# -- | Encode (# Integer mantissa, Int# exponent #) into a Double#
integerEncodeDouble# :: Integer -> Int# -> Double# integerEncodeDouble# :: Integer -> Int# -> Double#
{-# NOINLINE integerEncodeDouble# #-} {-# 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