[Git][ghc/ghc][wip/T18092] Inline `decodeDoubleInteger` and constant-fold `decodeDouble_Int64#` instead
Sebastian Graf
gitlab at gitlab.haskell.org
Mon Apr 27 09:21:20 UTC 2020
Sebastian Graf pushed to branch wip/T18092 at Glasgow Haskell Compiler / GHC
Commits:
b0814369 by Sebastian Graf at 2020-04-27T11:20:16+02:00
Inline `decodeDoubleInteger` and constant-fold `decodeDouble_Int64#` instead
Currently, `decodeDoubleInteger` 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`/`CONSTANT_FOLDED` things since #13143.
Also it is a trade-off: The implementation of `decodeDoubleInteger`
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 `decodeDoubleInteger`. As a result,
`decodeDoubleInteger` 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.
You may wonder how this affects performance of code using
`integer-simple`; Apparently, according to @hsyl20 this is not a concern
since we will hopefully land !2231 soon.
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/integer-gmp/src/GHC/Integer/Type.hs
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -381,7 +381,6 @@ basicKnownKeyNames
quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
floatFromIntegerName, doubleFromIntegerName,
encodeFloatIntegerName, encodeDoubleIntegerName,
- decodeDoubleIntegerName,
gcdIntegerName, lcmIntegerName,
andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
shiftLIntegerName, shiftRIntegerName, bitIntegerName,
@@ -1125,7 +1124,6 @@ integerTyConName, mkIntegerName, integerSDataConName,
quotIntegerName, remIntegerName, divIntegerName, modIntegerName,
floatFromIntegerName, doubleFromIntegerName,
encodeFloatIntegerName, encodeDoubleIntegerName,
- decodeDoubleIntegerName,
gcdIntegerName, lcmIntegerName,
andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name
@@ -1163,7 +1161,6 @@ floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger")
doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey
encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey
encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey
-decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey
gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey
lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey
andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey
@@ -2149,7 +2146,6 @@ mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey,
quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey,
floatFromIntegerIdKey, doubleFromIntegerIdKey,
encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey,
- decodeDoubleIntegerIdKey,
gcdIntegerIdKey, lcmIntegerIdKey,
andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey,
shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique
@@ -2193,7 +2189,8 @@ shiftRIntegerIdKey = mkPreludeMiscIdUnique 96
wordToIntegerIdKey = mkPreludeMiscIdUnique 97
word64ToIntegerIdKey = mkPreludeMiscIdUnique 98
int64ToIntegerIdKey = mkPreludeMiscIdUnique 99
-decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100
+-- This one is "free"
+-- decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100
rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 101
=====================================
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
@@ -235,32 +234,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
@@ -502,6 +503,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
@@ -510,6 +520,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1317,7 +1343,6 @@ builtinIntegerRules =
rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat,
rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat),
rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
- rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName,
rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble),
rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr,
rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr,
@@ -1390,9 +1415,6 @@ builtinIntegerRules =
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_XToIntegerToX str name toIntegerName
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_XToIntegerToX 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 integerTy),
- Lit (mkLitInt (roPlatform env) (toInteger z))]
- _ ->
- pprPanic "match_decodeDouble: Id has the wrong type"
- (ppr fn <+> dcolon <+> ppr (idType fn))
-match_decodeDouble _ _ _ _ = Nothing
-
match_XToIntegerToX :: Name -> RuleFun
match_XToIntegerToX n _ _ _ [App (Var x) y]
| idName x == n
=====================================
libraries/integer-gmp/src/GHC/Integer/Type.hs
=====================================
@@ -1618,7 +1618,6 @@ foreign import ccall unsafe "integer_gmp_invert"
-- Conversions to/from floating point
decodeDoubleInteger :: Double# -> (# Integer, Int# #)
--- decodeDoubleInteger 0.0## = (# S# 0#, 0# #)
#if WORD_SIZE_IN_BITS == 64
decodeDoubleInteger x = case decodeDouble_Int64# x of
(# m#, e# #) -> (# S# m#, e# #)
@@ -1626,7 +1625,10 @@ decodeDoubleInteger x = case decodeDouble_Int64# x of
decodeDoubleInteger x = case decodeDouble_Int64# x of
(# m#, e# #) -> (# int64ToInteger m#, e# #)
#endif
-{-# CONSTANT_FOLDED decodeDoubleInteger #-}
+-- Rather than constant-folding `decodeDoubleInteger`, we have constant-folding
+-- RULEs for the `decodeDouble_Int64#` PrimOp. Hence we inline this function.
+-- As a bonus, inlining might eliminate the S# box!
+{-# INLINE decodeDoubleInteger #-}
-- provided by GHC's RTS
foreign import ccall unsafe "__int_encodeDouble"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b08143695d1e38c458c3bc98a591420a653cb7cb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b08143695d1e38c458c3bc98a591420a653cb7cb
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/20200427/410ae122/attachment-0001.html>
More information about the ghc-commits
mailing list