[Git][ghc/ghc][wip/T18092] Inline `integerDecodeDouble#` and constant-fold `decodeDouble_Int64#` instead
Sebastian Graf
gitlab at gitlab.haskell.org
Wed Sep 30 17:20:38 UTC 2020
Sebastian Graf pushed to branch wip/T18092 at Glasgow Haskell Compiler / GHC
Commits:
70734034 by Sebastian Graf at 2020-09-30T19:17:32+02:00
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
- - - - -
3 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- libraries/ghc-bignum/src/GHC/Num/Integer.hs
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -379,7 +379,6 @@ basicKnownKeyNames
integerToDoubleName,
integerEncodeFloatName,
integerEncodeDoubleName,
- integerDecodeDoubleName,
integerGcdName,
integerLcmName,
integerAndName,
@@ -397,7 +396,6 @@ basicKnownKeyNames
naturalRemName,
naturalQuotRemName,
bignatFromWordListName,
-
-- Float/Double
rationalToFloatName,
rationalToDoubleName,
@@ -1155,7 +1153,6 @@ integerFromNaturalName
, integerToDoubleName
, integerEncodeFloatName
, integerEncodeDoubleName
- , integerDecodeDoubleName
, integerGcdName
, integerLcmName
, integerAndName
@@ -1223,7 +1220,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
=====================================
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
@@ -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
=====================================
libraries/ghc-bignum/src/GHC/Num/Integer.hs
=====================================
@@ -1040,15 +1040,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# #-}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7073403463b96a5be8903929aa0bc85cd1dfed20
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7073403463b96a5be8903929aa0bc85cd1dfed20
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200930/65e52fa4/attachment-0001.html>
More information about the ghc-commits
mailing list