[Git][ghc/ghc][ghc-9.4] 2 commits: Add -dsuppress-coercion-types to make coercions even smaller.
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Mon Nov 21 23:23:18 UTC 2022
Andreas Klebinger pushed to branch ghc-9.4 at Glasgow Haskell Compiler / GHC
Commits:
36a2eebf by Andreas Klebinger at 2022-11-10T13:32:16+01:00
Add -dsuppress-coercion-types to make coercions even smaller.
Instead of `` `cast` <Co:11> :: (Some -> Really -> Large Type)``
simply print `` `cast` <Co:11> :: ... ``
- - - - -
81cae7b7 by Andreas Klebinger at 2022-11-21T14:35:08+01:00
Fix #22425 - Broken eta-expansion over expensive work.
Through a mistake in the latest backport we started eta-expanding over
expensive work by mistake. E.g. over <expensive> in code like:
case x of
A -> id
B -> <expensive>
We fix this by only eta-expanding over <expensive> if all other branches
are headed by an oneShot lambda.
In the long story of broken eta-expansion on 9.2/9.4 this is hopefully
the last chapter.
-------------------------
Metric Increase:
CoOpt_Read
T1969
parsing001
TcPlugin_RewritePerf
LargeRecord
-------------------------
- - - - -
7 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Utils/Outputable.hs
- docs/users_guide/debugging.rst
- testsuite/tests/numeric/should_compile/T15547.stderr
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -853,7 +853,7 @@ andArityType env (AT [] div1) at2 = andWithTail env div1 at2
andArityType env at1 (AT [] div2) = andWithTail env div2 at1
andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType
-andWithTail env div1 at2@(AT lams2 _)
+andWithTail env div1 at2
| isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e }
= at2 -- Note [ABot branches: max arity wins]
@@ -861,7 +861,7 @@ andWithTail env div1 at2@(AT lams2 _)
= AT [] topDiv
| otherwise -- case x of { T -> plusInt <expensive>; F -> \y.e }
- = AT lams2 topDiv -- We know div1 = topDiv
+ = takeWhileOneShot at2 -- We know div1 = topDiv
-- See Note [Combining case branches: andWithTail]
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -172,8 +172,12 @@ noParens pp = pp
pprOptCo :: Coercion -> SDoc
-- Print a coercion optionally; i.e. honouring -dsuppress-coercions
pprOptCo co = sdocOption sdocSuppressCoercions $ \case
- True -> angleBrackets (text "Co:" <> int (coercionSize co)) <+> dcolon <+> ppr (coercionType co)
- False -> parens $ sep [ppr co, dcolon <+> ppr (coercionType co)]
+ True -> angleBrackets (text "Co:" <> int (coercionSize co)) <+> dcolon <+> co_type
+ False -> parens $ sep [ppr co, dcolon <+> co_type]
+ where
+ co_type = sdocOption sdocSuppressCoercionTypes $ \case
+ True -> text "..."
+ False -> ppr (coercionType co)
ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc
ppr_id_occ add_par id
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -353,8 +353,10 @@ data GeneralFlag
| Opt_ShowLoadedModules
| Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals]
- -- Suppress all coercions, them replacing with '...'
+ -- Suppress a coercions inner structure, replacing it with '...'
| Opt_SuppressCoercions
+ -- Suppress the type of a coercion as well
+ | Opt_SuppressCoercionTypes
| Opt_SuppressVarKinds
-- Suppress module id prefixes on variables.
| Opt_SuppressModulePrefixes
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2427,6 +2427,7 @@ dynamic_flags_deps = [
-- have otherwise identical names.
, make_ord_flag defGhcFlag "dsuppress-all"
(NoArg $ do setGeneralFlag Opt_SuppressCoercions
+ setGeneralFlag Opt_SuppressCoercionTypes
setGeneralFlag Opt_SuppressVarKinds
setGeneralFlag Opt_SuppressModulePrefixes
setGeneralFlag Opt_SuppressTypeApplications
@@ -3372,6 +3373,7 @@ dFlagsDeps = [
(useInstead "-d" "suppress-stg-exts"),
flagSpec "suppress-stg-exts" Opt_SuppressStgExts,
flagSpec "suppress-coercions" Opt_SuppressCoercions,
+ flagSpec "suppress-coercion-types" Opt_SuppressCoercionTypes,
flagSpec "suppress-idinfo" Opt_SuppressIdInfo,
flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings,
flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes,
@@ -5023,6 +5025,7 @@ initSDocContext dflags style = SDC
, sdocSuppressTypeApplications = gopt Opt_SuppressTypeApplications dflags
, sdocSuppressIdInfo = gopt Opt_SuppressIdInfo dflags
, sdocSuppressCoercions = gopt Opt_SuppressCoercions dflags
+ , sdocSuppressCoercionTypes = gopt Opt_SuppressCoercionTypes dflags
, sdocSuppressUnfoldings = gopt Opt_SuppressUnfoldings dflags
, sdocSuppressVarKinds = gopt Opt_SuppressVarKinds dflags
, sdocSuppressUniques = gopt Opt_SuppressUniques dflags
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -376,6 +376,7 @@ data SDocContext = SDC
, sdocSuppressTypeApplications :: !Bool
, sdocSuppressIdInfo :: !Bool
, sdocSuppressCoercions :: !Bool
+ , sdocSuppressCoercionTypes :: !Bool
, sdocSuppressUnfoldings :: !Bool
, sdocSuppressVarKinds :: !Bool
, sdocSuppressUniques :: !Bool
@@ -435,6 +436,7 @@ defaultSDocContext = SDC
, sdocSuppressTypeApplications = False
, sdocSuppressIdInfo = False
, sdocSuppressCoercions = False
+ , sdocSuppressCoercionTypes = False
, sdocSuppressUnfoldings = False
, sdocSuppressVarKinds = False
, sdocSuppressUniques = False
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -910,6 +910,11 @@ parts that you are not interested in.
Suppress the printing of type coercions.
+.. ghc-flag:: -dsuppress-coercion-types
+ :shortdesc: Suppress the printing of coercion types in Core dumps to make them
+ shorter
+ :type: dynamic
+
.. ghc-flag:: -dsuppress-var-kinds
:shortdesc: Suppress the printing of variable kinds
:type: dynamic
=====================================
testsuite/tests/numeric/should_compile/T15547.stderr
=====================================
@@ -5,31 +5,25 @@ Result size of Tidy Core
nat2Word#
= \ @n $dKnownNat _ ->
- naturalToWord# ($dKnownNat `cast` <Co:5> :: KnownNat n ~R# Natural)
+ naturalToWord# ($dKnownNat `cast` <Co:5> :: ...)
foo = \ _ -> 18##
fd
= \ @n $dKnownNat _ ->
- naturalToWord#
- ($dKnownNat
- `cast` <Co:13> :: KnownNat (Div (n + 63) 64) ~R# Natural)
+ naturalToWord# ($dKnownNat `cast` <Co:13> :: ...)
d = \ _ -> 3##
fm
= \ @n $dKnownNat _ ->
- naturalToWord#
- ($dKnownNat
- `cast` <Co:17> :: KnownNat (Mod (n - 1) 64 + 1) ~R# Natural)
+ naturalToWord# ($dKnownNat `cast` <Co:17> :: ...)
m = \ _ -> 9##
fp
= \ @n $dKnownNat _ ->
- naturalToWord#
- ($dKnownNat
- `cast` <Co:21> :: KnownNat (2 ^ (Mod (n + 63) 64 + 1)) ~R# Natural)
+ naturalToWord# ($dKnownNat `cast` <Co:21> :: ...)
p = \ _ -> 512##
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/79a09016efc097b34f2229990c39bd18d3303fa7...81cae7b73588ad77ef2e8e0e1dbe4052ecd0155f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/79a09016efc097b34f2229990c39bd18d3303fa7...81cae7b73588ad77ef2e8e0e1dbe4052ecd0155f
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/20221121/a506f9e8/attachment-0001.html>
More information about the ghc-commits
mailing list