[Git][ghc/ghc][wip/T18092] Inline `decodeDoubleInteger` and constant-fold `decodeDouble_Int64#` instead

Sebastian Graf gitlab at gitlab.haskell.org
Fri Apr 24 10:00:36 UTC 2020



Sebastian Graf pushed to branch wip/T18092 at Glasgow Haskell Compiler / GHC


Commits:
a3c86479 by Sebastian Graf at 2020-04-24T12:00:19+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,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 +1333,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 +1405,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 +1759,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/a3c86479ccadaa39688dd373325b0ac021efeb75

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3c86479ccadaa39688dd373325b0ac021efeb75
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/54f61f89/attachment-0001.html>


More information about the ghc-commits mailing list