[Git][ghc/ghc][wip/nested-cpr-2019] 4 commits: Inline `decodeDoubleInteger` and constant-fold `decodeDouble_Int64#` instead
Sebastian Graf
gitlab at gitlab.haskell.org
Sun Apr 26 22:11:23 UTC 2020
Sebastian Graf pushed to branch wip/nested-cpr-2019 at Glasgow Haskell Compiler / GHC
Commits:
ddae31fb by Sebastian Graf at 2020-04-24T12:00:54+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`.
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.
- - - - -
df4ed5c7 by Sebastian Graf at 2020-04-24T12:50:41+02:00
Fix primop termination
- - - - -
f644a361 by Sebastian Graf at 2020-04-26T23:53:03+02:00
Test for DataCon wrapper CPR
- - - - -
d9cba900 by Sebastian Graf at 2020-04-27T00:11:12+02:00
Fix CPR of bottoming functions/primops
- - - - -
13 changed files:
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Types/Cpr.hs
- compiler/GHC/Types/Id/Make.hs
- libraries/integer-gmp/src/GHC/Integer/Type.hs
- + testsuite/tests/cpranal/sigs/DataConWrapperCpr.hs
- + testsuite/tests/cpranal/sigs/DataConWrapperCpr.stderr
- testsuite/tests/cpranal/sigs/all.T
Changes:
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -798,7 +798,7 @@ aBSENT_SUM_FIELD_ERROR_ID
= mkVanillaGlobalWithInfo absentSumFieldErrorName
(mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a
(vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botDiv
- `setCprInfo` mkCprSig 0 botCpr
+ `setCprInfo` mkCprSig 0 divergeCpr
`setArityInfo` 0
`setCafInfo` NoCafRefs) -- #15038
@@ -813,7 +813,7 @@ mkRuntimeErrorId name
= mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info
where
bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
- `setCprInfo` mkCprSig 1 botCpr
+ `setCprInfo` mkCprSig 1 divergeCpr
`setArityInfo` 1
-- Make arity and strictness agree
=====================================
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
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -208,7 +208,7 @@ cprAnal' env args (Case scrut case_bndr ty alts)
-- Regardless of whether scrut had the CPR property or not, the case binder
-- certainly has it. See 'extendEnvForDataAlt'.
(alt_tys, alts') = mapAndUnzip (cprAnalAlt env args case_bndr case_bndr_ty) alts
- res_ty = foldl' lubCprType botCprType alt_tys `bothCprType` whnf_flag
+ res_ty = lubCprTypes alt_tys `bothCprType` whnf_flag
cprAnal' env args (Let (NonRec id rhs) body)
= (body_ty, Let (NonRec id' rhs') body')
@@ -279,7 +279,7 @@ cprFix
cprFix top_lvl env str orig_pairs
= loop 1 initial_pairs
where
- init_sig id = mkCprSig (idArity id) initRecFunCpr
+ init_sig id = mkCprSig (idArity id) divergeCpr
-- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal
initial_pairs | ae_virgin env = [(setIdCprInfo id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]
| otherwise = orig_pairs
@@ -328,7 +328,7 @@ pruneSig d (CprSig cpr_ty)
-- of functions like iterate, which we would CPR
-- multiple levels deep, thereby changing termination
-- behavior.
- = CprSig $ cpr_ty { ct_cpr = pruneDeepCpr d (ct_cpr cpr_ty `lubCpr` initRecFunCpr) }
+ = CprSig $ cpr_ty { ct_cpr = pruneDeepCpr d (ct_cpr cpr_ty `lubCpr` divergeCpr) }
unboxingStrategy :: AnalEnv -> UnboxingStrategy
unboxingStrategy env ty dmd
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -88,7 +88,7 @@ import GHC.Types.Unique.DSet ( getUniqDSet )
import GHC.Types.Var.Env
import GHC.Types.Literal ( litIsTrivial )
import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )
-import GHC.Types.Cpr ( mkCprSig, botCpr )
+import GHC.Types.Cpr ( mkCprSig, divergeCpr )
import GHC.Types.Name ( getOccName, mkSystemVarName )
import GHC.Types.Name.Occurrence ( occNameString )
import GHC.Core.Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType
@@ -984,7 +984,7 @@ annotateBotStr id n_extra mb_str
Nothing -> id
Just (arity, sig) -> id `setIdArity` (arity + n_extra)
`setIdStrictness` (increaseStrictSigArity n_extra sig)
- `setIdCprInfo` mkCprSig (arity + n_extra) botCpr
+ `setIdCprInfo` mkCprSig (arity + n_extra) divergeCpr
notWorthFloating :: CoreExpr -> [Var] -> Bool
-- Returns True if the expression would be replaced by
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -39,7 +39,7 @@ import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )
import GHC.Core
import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd
, mkClosedStrictSig, topDmd, botDiv )
-import GHC.Types.Cpr ( mkCprSig, botCpr )
+import GHC.Types.Cpr ( mkCprSig, divergeCpr )
import GHC.Core.Ppr ( pprCoreExpr )
import GHC.Core.Unfold
import GHC.Core.Utils
@@ -739,7 +739,7 @@ addLetBndrInfo new_bndr new_arity is_bot new_unf
info4 | is_bot = info3
`setStrictnessInfo`
mkClosedStrictSig (replicate new_arity topDmd) botDiv
- `setCprInfo` mkCprSig new_arity botCpr
+ `setCprInfo` mkCprSig new_arity divergeCpr
| otherwise = info3
-- Zap call arity info. We have used it by now (via
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -1255,7 +1255,7 @@ mk_absent_let dflags fam_envs arg
= WARN( True, text "No absent value for" <+> ppr arg_ty )
Nothing -- Can happen for 'State#' and things of 'VecRep'
where
- lifted_arg = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 botCpr
+ lifted_arg = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 divergeCpr
-- Note in strictness signature that this is bottoming
-- (for the sake of the "empty case scrutinee not known to
-- diverge for sure lint" warning)
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -40,7 +40,7 @@ import GHC.Types.Id.Info
import GHC.Core.InstEnv
import GHC.Core.Type ( tidyTopType )
import GHC.Types.Demand ( appIsBottom, isTopSig, isBottomingSig )
-import GHC.Types.Cpr ( mkCprSig, botCpr )
+import GHC.Types.Cpr ( mkCprSig, divergeCpr )
import GHC.Types.Basic
import GHC.Types.Name hiding (varName)
import GHC.Types.Name.Set
@@ -1223,7 +1223,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
cpr = cprInfo idinfo
final_cpr | Just _ <- mb_bot_str
- = mkCprSig arity botCpr
+ = mkCprSig arity divergeCpr
| otherwise
= cpr
=====================================
compiler/GHC/Types/Cpr.hs
=====================================
@@ -10,8 +10,8 @@
-- and "GHC.Core.Opt.WorkWrap.Utils" are its primary customers via 'idCprInfo'.
module GHC.Types.Cpr (
TerminationFlag (Terminates),
- Cpr, topCpr, botCpr, conCpr, whnfTermCpr, initRecFunCpr, lubCpr, asConCpr,
- CprType (..), topCprType, botCprType, whnfTermCprType, conCprType, lubCprType,
+ Cpr, topCpr, conCpr, whnfTermCpr, divergeCpr, lubCpr, asConCpr,
+ CprType (..), topCprType, whnfTermCprType, conCprType, lubCprType, lubCprTypes,
pruneDeepCpr, markConCprType, splitConCprTy, applyCprTy, abstractCprTy,
abstractCprTyNTimes, ensureCprTyArity, trimCprTy,
forceCprTy, forceCpr, bothCprType,
@@ -194,12 +194,17 @@ topCpr = Cpr MightDiverge Top
whnfTermCpr :: Cpr
whnfTermCpr = Cpr Terminates Top
--- | The initial termination of a recursive function in fixed-point iteration.
--- We assume a recursive call 'MightDiverge', but are optimistic about all
--- CPR and nested termination information. I.e., we assume that evaluating
--- returned tuple components 'Terminates' rapidly.
-initRecFunCpr :: Cpr
-initRecFunCpr = Cpr MightDiverge Bot
+-- | Used as
+--
+-- * The initial CPR of a recursive function in fixed-point iteration
+-- * The CPR of 'undefined'/'error'/other sources of divergence.
+--
+-- We assume that evaluation to WHNF surely diverges (so 'MightDiverge'), but
+-- are optimistic about all CPR and nested termination information. I.e., we
+-- assume that returned tuple components terminate rapidly and construct a
+-- product.
+divergeCpr :: Cpr
+divergeCpr = Cpr MightDiverge Bot
conCpr :: TerminationFlag -> ConTag -> [Cpr] -> Cpr
conCpr tf t fs = Cpr tf (Levitate (Con t fs))
@@ -219,7 +224,8 @@ lubCpr cpr1 cpr2
= NoMoreCpr (lubTerm (forgetCpr cpr1) (forgetCpr cpr2))
trimCpr :: Cpr -> Cpr
-trimCpr = NoMoreCpr . forgetCpr
+trimCpr cpr@(Cpr _ Bot) = cpr -- don't trim away bottom (we didn't do so before Nested CPR) TODO: Explain; CPR'ing for the error case
+trimCpr cpr = NoMoreCpr (forgetCpr cpr)
pruneDeepCpr :: Int -> Cpr -> Cpr
pruneDeepCpr depth (Cpr tf (Levitate sh)) = Cpr tf (pruneKnownShape pruneDeepCpr depth sh)
@@ -282,6 +288,9 @@ lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2)
| otherwise
= topCprType
+lubCprTypes :: [CprType] -> CprType
+lubCprTypes = foldl' lubCprType botCprType
+
extractArgCprAndTermination :: [CprType] -> [Cpr]
extractArgCprAndTermination = map go
where
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -637,8 +637,6 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
-- particular, the wrapper constructor is not inlined inside
-- an INLINE rhs or when it is not applied to any arguments.
-- See Note [Inline partially-applied constructor wrappers]
- -- Passing Nothing here allows the wrapper to inline when
- -- unsaturated.
wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs
-- See Note [Compulsory newtype unfolding]
| otherwise = mkInlineUnfolding wrap_rhs
@@ -1216,9 +1214,17 @@ mkPrimOpId prim_op
(AnId id) UserSyntax
id = mkGlobalId (PrimOpId prim_op) name ty info
- -- PrimOps don't ever construct a product, but we want to preserve bottoms
- cpr | isBotDiv (snd (splitStrictSig strict_sig)) = initRecFunCpr
- | otherwise = whnfTermCpr
+ -- PrimOps never construct a product, but we want to assume that
+ -- 1. Cheap ones (i.e. `+#`) terminate.
+ -- 2. Those which have dead end Divergence (i.e. `raise#`) have
+ -- `divergeCpr`. If we manage to evaluate them to WHNF (which we
+ -- never do), they have infinitely deep CPR and termination: This is
+ -- so that we give an `if ... then error "blah" else (1, 2)` the
+ -- nested CPR property.
+ -- In all other cases we simply assume `topCpr`.
+ cpr | primOpIsCheap prim_op = whnfTermCpr
+ | isBottomingSig strict_sig = divergeCpr
+ | otherwise = topCpr
info = noCafIdInfo
`setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op)
=====================================
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"
=====================================
testsuite/tests/cpranal/sigs/DataConWrapperCpr.hs
=====================================
@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+module DataConWrapperCpr where
+
+data Foo = Foo !Int
+
+-- Should have the CPR property! Hence the wrapper $WFoo must have it.
+foo :: Int -> Foo
+foo = Foo
=====================================
testsuite/tests/cpranal/sigs/DataConWrapperCpr.stderr
=====================================
@@ -0,0 +1,12 @@
+
+==================== Cpr signatures ====================
+DataConWrapperCpr.$tc'Foo: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#),
+ #,
+ #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
+ #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *)))
+DataConWrapperCpr.$tcFoo: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
+ #c5(*))
+DataConWrapperCpr.$trModule: #c1(#c1(#), #c1(#))
+DataConWrapperCpr.foo: #c1(#)
+
+
=====================================
testsuite/tests/cpranal/sigs/all.T
=====================================
@@ -12,3 +12,4 @@ test('CaseBinderCPR', normal, compile, [''])
test('T5075', normal, compile, [''])
test('T10694', normal, compile, [''])
test('T1600', normal, compile, [''])
+test('DataConWrapperCpr', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fec46cbba409e405f49d1aade0ad5f639a1632e4...d9cba900985a8b4d2cb17c699c47e93b61a371e7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fec46cbba409e405f49d1aade0ad5f639a1632e4...d9cba900985a8b4d2cb17c699c47e93b61a371e7
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/20200426/285ecbe5/attachment-0001.html>
More information about the ghc-commits
mailing list