[Git][ghc/ghc][wip/T18092] Inline `decodeDoubleInteger` and constant-fold `decodeDouble_Int64#` instead
Sebastian Graf
gitlab at gitlab.haskell.org
Fri Apr 24 09:40:20 UTC 2020
Sebastian Graf pushed to branch wip/T18092 at Glasgow Haskell Compiler / GHC
Commits:
2ae68627 by Sebastian Graf at 2020-04-24T11:39:27+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.
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.
Fixes #18092.
- - - - -
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
@@ -249,18 +248,19 @@ primOpRules nm = \case
, inversePrimOp FloatNegOp ]
-- 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
@@ -510,6 +510,23 @@ 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 (roPlatform env) (toInteger e) ]
+ where
+#if WORD_SIZE_IN_BITS < 64
+ iNT64Ty = intPrimTy
+ mkLitINT64 = mkLitInt64Wrap
+#else
+ iNT64Ty = int64PrimTy
+ mkLitINT64 = mkLitIntWrap
+#endif
+doubleDecodeOp _ _
+ = Nothing
+
--------------------------
{- Note [The litEq rule: converting equality to case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1317,7 +1334,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 +1406,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 +1760,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,7 @@ decodeDoubleInteger x = case decodeDouble_Int64# x of
decodeDoubleInteger x = case decodeDouble_Int64# x of
(# m#, e# #) -> (# int64ToInteger m#, e# #)
#endif
-{-# CONSTANT_FOLDED decodeDoubleInteger #-}
+{-# INLINE decodeDoubleInteger #-}
-- provided by GHC's RTS
foreign import ccall unsafe "__int_encodeDouble"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2ae68627e79e532cc1e75f1c26d5e6fbe7f4ac08
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2ae68627e79e532cc1e75f1c26d5e6fbe7f4ac08
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/20200424/46871837/attachment-0001.html>
More information about the ghc-commits
mailing list