[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Add 'docWithStyle' to improve codegen
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Jan 12 04:08:35 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
f7ceafc9 by Krzysztof Gogolewski at 2023-01-11T22:36:59-05:00
Add 'docWithStyle' to improve codegen
This new combinator
docWithStyle :: IsOutput doc => doc -> (PprStyle -> SDoc) -> doc
let us remove the need for code to be polymorphic in HDoc
when not used in code style.
Metric Decrease:
ManyConstructors
T13035
T1969
- - - - -
b3be0d18 by Simon Peyton Jones at 2023-01-11T22:37:35-05:00
Fix finaliseArgBoxities for OPAQUE function
We never do worker wrapper for OPAQUE functions, so we must
zap the unboxing info during strictness analysis.
This patch fixes #22502
- - - - -
5c99e471 by Ben Gamari at 2023-01-11T23:08:22-05:00
Revert "rts: Drop racy assertion"
The logic here was inverted. Reverting the commit to avoid confusion
when examining the commit history.
This reverts commit b3eacd64fb36724ed6c5d2d24a81211a161abef1.
- - - - -
dc0fc26f by Ben Gamari at 2023-01-11T23:08:22-05:00
rts: Drop racy assertion
0e274c39bf836d5bb846f5fa08649c75f85326ac added an assertion in
`dirty_MUT_VAR` checking that the MUT_VAR being dirtied was clean.
However, this isn't necessarily the case since another thread may have
raced us to dirty the object.
- - - - -
d2b9771c by Ben Gamari at 2023-01-11T23:08:22-05:00
configure: Fix escaping of `$tooldir`
In !9547 I introduced `$tooldir` directories into GHC's default link and
compilation flags to ensure that our C toolchain finds its own headers
and libraries before others on the system. However, the patch was subtly
wrong in the escaping of `$tooldir`. Fix this.
Fixes #22561.
- - - - -
10 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Types/CostCentre.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Types/Name/Occurrence.hs
- compiler/GHC/Unit/Types.hs
- compiler/GHC/Utils/Outputable.hs
- m4/fp_settings.m4
- rts/sm/Storage.c
- + testsuite/tests/simplCore/should_compile/T22502.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -41,7 +41,6 @@ import GHC.Core.Opt.Arity ( typeArity )
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
-import GHC.Data.Maybe
import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
import GHC.Types.Unique.Set
@@ -1078,9 +1077,8 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs
DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
- -- See Note [Boxity for bottoming functions]
- (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity rhs' rhs_div
- `orElse` (rhs_dmds, rhs')
+ (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity
+ rhs_dmds rhs_div rhs'
sig = mkDmdSigForArity threshold_arity (DmdType sig_fv final_rhs_dmds rhs_div)
@@ -1259,7 +1257,9 @@ The threshold we use is
* Ordinary bindings: idArity f.
Why idArity arguments? Because that's a conservative estimate of how many
arguments we must feed a function before it does anything interesting with
- them. Also it elegantly subsumes the trivial RHS and PAP case.
+ them. Also it elegantly subsumes the trivial RHS and PAP case. E.g. for
+ f = g
+ we want to use a threshold arity based on g, not 0!
idArity is /at least/ the number of manifest lambdas, but might be higher for
PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]).
@@ -1909,21 +1909,37 @@ spendTopBudget m (MkB n bg) = MkB (n-m) bg
positiveTopBudget :: Budgets -> Bool
positiveTopBudget (MkB n _) = n >= 0
-finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence
- -> Maybe ([Demand], CoreExpr)
-finaliseArgBoxities env fn arity rhs div
- | arity > count isId bndrs -- Can't find enough binders
- = Nothing -- This happens if we have f = g
- -- Then there are no binders; we don't worker/wrapper; and we
- -- simply want to give f the same demand signature as g
-
- | otherwise -- NB: arity is the threshold_arity, which might be less than
+finaliseArgBoxities :: AnalEnv -> Id -> Arity
+ -> [Demand] -> Divergence
+ -> CoreExpr -> ([Demand], CoreExpr)
+finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs
+
+ -- Check for an OPAQUE function: see Note [OPAQUE pragma]
+ -- In that case, trim off all boxity info from argument demands
+ -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
+ | isOpaquePragma (idInlinePragma fn)
+ , let trimmed_rhs_dmds = map trimBoxity rhs_dmds
+ = (trimmed_rhs_dmds, add_demands trimmed_rhs_dmds rhs)
+
+ -- Check that we have enough visible binders to match the
+ -- threshold arity; if not, we won't do worker/wrapper
+ -- This happens if we have simply {f = g} or a PAP {f = h 13}
+ -- we simply want to give f the same demand signature as g
+ -- How can such bindings arise? Perhaps from {-# NOLINE[2] f #-},
+ -- or if the call to `f` is currently not-applied (map f xs).
+ -- It's a bit of a corner case. Anyway for now we pass on the
+ -- unadulterated demands from the RHS, without any boxity trimming.
+ | threshold_arity > count isId bndrs
+ = (rhs_dmds, rhs)
+
+ -- The normal case
+ | otherwise -- NB: threshold_arity might be less than
-- manifest arity for join points
= -- pprTrace "finaliseArgBoxities" (
-- vcat [text "function:" <+> ppr fn
-- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))
-- , text "dmds after: " <+> ppr arg_dmds' ]) $
- Just (arg_dmds', add_demands arg_dmds' rhs)
+ (arg_dmds', add_demands arg_dmds' rhs)
-- add_demands: we must attach the final boxities to the lambda-binders
-- of the function, both because that's kosher, and because CPR analysis
-- uses the info on the binders directly.
@@ -1941,7 +1957,7 @@ finaliseArgBoxities env fn arity rhs div
(remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples
arg_triples :: [(Type, StrictnessMark, Demand)]
- arg_triples = take arity $
+ arg_triples = take threshold_arity $
[ (bndr_ty, NotMarkedStrict, get_dmd bndr bndr_ty)
| bndr <- bndrs
, isRuntimeVar bndr, let bndr_ty = idType bndr ]
@@ -1957,14 +1973,9 @@ finaliseArgBoxities env fn arity rhs div
| is_bot_fn = unboxDeeplyDmd dmd
-- See Note [Boxity for bottoming functions], case (B)
- | is_opaque = trimBoxity dmd
- -- See Note [OPAQUE pragma]
- -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
-
| otherwise = dmd
where
- dmd = idDemandInfo bndr
- is_opaque = isOpaquePragma (idInlinePragma fn)
+ dmd = idDemandInfo bndr
-- is_bot_fn: see Note [Boxity for bottoming functions]
is_bot_fn = div == botDiv
@@ -2027,6 +2038,10 @@ finaliseArgBoxities env fn arity rhs div
add_demands (dmd:dmds) (Lam v e)
| isTyVar v = Lam v (add_demands (dmd:dmds) e)
| otherwise = Lam (v `setIdDemandInfo` dmd) (add_demands dmds e)
+ add_demands dmds (Cast e co) = Cast (add_demands dmds e) co
+ -- This case happens for an OPAQUE function, which may look like
+ -- f = (\x y. blah) |> co
+ -- We give it strictness but no boxity (#22502)
add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e)
finaliseLetBoxity
=====================================
compiler/GHC/Types/CostCentre.hs
=====================================
@@ -265,10 +265,8 @@ instance Outputable CostCentre where
ppr = pprCostCentre
pprCostCentre :: IsLine doc => CostCentre -> doc
-pprCostCentre cc = docWithContext $ \ sty ->
- if codeStyle (sdocStyle sty)
- then ppCostCentreLbl cc
- else ftext (costCentreUserNameFS cc)
+pprCostCentre cc = docWithStyle (ppCostCentreLbl cc)
+ (\_ -> ftext (costCentreUserNameFS cc))
{-# SPECIALISE pprCostCentre :: CostCentre -> SDoc #-}
{-# SPECIALISE pprCostCentre :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
=====================================
compiler/GHC/Types/Name.hs
=====================================
@@ -627,21 +627,30 @@ instance OutputableBndr Name where
pprName :: forall doc. IsLine doc => Name -> doc
pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
- = docWithContext $ \ctx ->
- let sty = sdocStyle ctx
- debug = sdocPprDebug ctx
- listTuplePuns = sdocListTuplePuns ctx
- in handlePuns listTuplePuns (namePun_maybe name) $
- case sort of
- WiredIn mod _ builtin -> pprExternal debug sty uniq mod occ True builtin
- External mod -> pprExternal debug sty uniq mod occ False UserSyntax
- System -> pprSystem debug sty uniq occ
- Internal -> pprInternal debug sty uniq occ
+ = docWithStyle codeDoc normalDoc
where
- -- Print GHC.Types.List as [], etc.
- handlePuns :: Bool -> Maybe FastString -> doc -> doc
- handlePuns True (Just pun) _ = ftext pun
- handlePuns _ _ r = r
+ codeDoc = case sort of
+ WiredIn mod _ _ -> pprModule mod <> char '_' <> ppr_z_occ_name occ
+ External mod -> pprModule mod <> char '_' <> ppr_z_occ_name occ
+ -- In code style, always qualify
+ -- ToDo: maybe we could print all wired-in things unqualified
+ -- in code style, to reduce symbol table bloat?
+ System -> pprUniqueAlways uniq
+ Internal -> pprUniqueAlways uniq
+
+ normalDoc sty =
+ getPprDebug $ \debug ->
+ sdocOption sdocListTuplePuns $ \listTuplePuns ->
+ handlePuns listTuplePuns (namePun_maybe name) $
+ case sort of
+ WiredIn mod _ builtin -> pprExternal debug sty uniq mod occ True builtin
+ External mod -> pprExternal debug sty uniq mod occ False UserSyntax
+ System -> pprSystem debug sty uniq occ
+ Internal -> pprInternal debug sty uniq occ
+
+ handlePuns :: Bool -> Maybe FastString -> SDoc -> SDoc
+ handlePuns True (Just pun) _ = ftext pun
+ handlePuns _ _ r = r
{-# SPECIALISE pprName :: Name -> SDoc #-}
{-# SPECIALISE pprName :: Name -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
@@ -674,12 +683,8 @@ pprTickyName this_mod name
pprNameUnqualified :: Name -> SDoc
pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ
-pprExternal :: IsLine doc => Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> doc
+pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc
pprExternal debug sty uniq mod occ is_wired is_builtin
- | codeStyle sty = pprModule mod <> char '_' <> ppr_z_occ_name occ
- -- In code style, always qualify
- -- ToDo: maybe we could print all wired-in things unqualified
- -- in code style, to reduce symbol table bloat?
| debug = pp_mod <> ppr_occ_name occ
<> braces (hsep [if is_wired then text "(w)" else empty,
pprNameSpaceBrief (occNameSpace occ),
@@ -695,9 +700,8 @@ pprExternal debug sty uniq mod occ is_wired is_builtin
pp_mod = ppUnlessOption sdocSuppressModulePrefixes
(pprModule mod <> dot)
-pprInternal :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc
+pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc
pprInternal debug sty uniq occ
- | codeStyle sty = pprUniqueAlways uniq
| debug = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ),
pprUnique uniq])
| dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq
@@ -706,9 +710,8 @@ pprInternal debug sty uniq occ
| otherwise = ppr_occ_name occ -- User style
-- Like Internal, except that we only omit the unique in Iface style
-pprSystem :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc
-pprSystem debug sty uniq occ
- | codeStyle sty = pprUniqueAlways uniq
+pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc
+pprSystem debug _sty uniq occ
| debug = ppr_occ_name occ <> ppr_underscore_unique uniq
<> braces (pprNameSpaceBrief (occNameSpace occ))
| otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq
@@ -717,7 +720,7 @@ pprSystem debug sty uniq occ
-- so print the unique
-pprModulePrefix :: IsLine doc => PprStyle -> Module -> OccName -> doc
+pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc
-- Print the "M." part of a name, based on whether it's in scope or not
-- See Note [Printing original names] in GHC.Types.Name.Ppr
pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $
@@ -728,20 +731,20 @@ pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $
<> pprModuleName (moduleName mod) <> dot -- scope either
NameUnqual -> empty -- In scope unqualified
-pprUnique :: IsLine doc => Unique -> doc
+pprUnique :: Unique -> SDoc
-- Print a unique unless we are suppressing them
pprUnique uniq
= ppUnlessOption sdocSuppressUniques $
pprUniqueAlways uniq
-ppr_underscore_unique :: IsLine doc => Unique -> doc
+ppr_underscore_unique :: Unique -> SDoc
-- Print an underscore separating the name from its unique
-- But suppress it if we aren't printing the uniques anyway
ppr_underscore_unique uniq
= ppUnlessOption sdocSuppressUniques $
char '_' <> pprUniqueAlways uniq
-ppr_occ_name :: IsLine doc => OccName -> doc
+ppr_occ_name :: OccName -> SDoc
ppr_occ_name occ = ftext (occNameFS occ)
-- Don't use pprOccName; instead, just print the string of the OccName;
-- we print the namespace in the debug stuff above
=====================================
compiler/GHC/Types/Name/Occurrence.hs
=====================================
@@ -201,7 +201,7 @@ pprNonVarNameSpace :: NameSpace -> SDoc
pprNonVarNameSpace VarName = empty
pprNonVarNameSpace ns = pprNameSpace ns
-pprNameSpaceBrief :: IsLine doc => NameSpace -> doc
+pprNameSpaceBrief :: NameSpace -> SDoc
pprNameSpaceBrief DataName = char 'd'
pprNameSpaceBrief VarName = char 'v'
pprNameSpaceBrief TvName = text "tv"
@@ -287,10 +287,9 @@ instance OutputableBndr OccName where
pprOccName :: IsLine doc => OccName -> doc
pprOccName (OccName sp occ)
- = docWithContext $ \ sty ->
- if codeStyle (sdocStyle sty)
- then ztext (zEncodeFS occ)
- else ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp))
+ = docWithStyle (ztext (zEncodeFS occ)) (\_ -> ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp)))
+{-# SPECIALIZE pprOccName :: OccName -> SDoc #-}
+{-# SPECIALIZE pprOccName :: OccName -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
{-
************************************************************************
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -166,7 +166,7 @@ instance Outputable InstantiatedModule where
instance Outputable InstantiatedUnit where
ppr = pprInstantiatedUnit
-pprInstantiatedUnit :: IsLine doc => InstantiatedUnit -> doc
+pprInstantiatedUnit :: InstantiatedUnit -> SDoc
pprInstantiatedUnit uid =
-- getPprStyle $ \sty ->
pprUnitId cid <>
@@ -180,8 +180,6 @@ pprInstantiatedUnit uid =
where
cid = instUnitInstanceOf uid
insts = instUnitInsts uid
-{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> SDoc #-}
-{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Class for types that are used as unit identifiers (UnitKey, UnitId, Unit)
--
@@ -203,14 +201,13 @@ instance IsUnitId u => IsUnitId (GenUnit u) where
unitFS HoleUnit = holeFS
pprModule :: IsLine doc => Module -> doc
-pprModule mod@(Module p n) = docWithContext (doc . sdocStyle)
+pprModule mod@(Module p n) = docWithStyle code doc
where
- doc sty
- | codeStyle sty =
- (if p == mainUnit
+ code = (if p == mainUnit
then empty -- never qualify the main package in code
else ztext (zEncodeFS (unitFS p)) <> char '_')
<> pprModuleName n
+ doc sty
| qualModule sty mod =
case p of
HoleUnit -> angleBrackets (pprModuleName n)
@@ -352,12 +349,10 @@ stableUnitCmp p1 p2 = unitFS p1 `lexicalCompareFS` unitFS p2
instance Outputable Unit where
ppr pk = pprUnit pk
-pprUnit :: IsLine doc => Unit -> doc
+pprUnit :: Unit -> SDoc
pprUnit (RealUnit (Definite d)) = pprUnitId d
pprUnit (VirtUnit uid) = pprInstantiatedUnit uid
pprUnit HoleUnit = ftext holeFS
-{-# SPECIALIZE pprUnit :: Unit -> SDoc #-}
-{-# SPECIALIZE pprUnit :: Unit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
instance Show Unit where
show = unitString
@@ -535,12 +530,8 @@ instance Uniquable UnitId where
instance Outputable UnitId where
ppr = pprUnitId
-pprUnitId :: IsLine doc => UnitId -> doc
-pprUnitId (UnitId fs) = dualLine (sdocOption sdocUnitIdForUser ($ fs)) (ftext fs)
- -- see Note [Pretty-printing UnitId] in GHC.Unit
- -- also see Note [dualLine and dualDoc] in GHC.Utils.Outputable
-{-# SPECIALIZE pprUnitId :: UnitId -> SDoc #-}
-{-# SPECIALIZE pprUnitId :: UnitId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+pprUnitId :: UnitId -> SDoc
+pprUnitId (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs)
-- | A 'DefUnitId' is an 'UnitId' with the invariant that
-- it only refers to a definite library; i.e., one we have generated
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -126,6 +126,7 @@ import GHC.Data.FastString
import qualified GHC.Utils.Ppr as Pretty
import qualified GHC.Utils.Ppr.Colour as Col
import GHC.Utils.Ppr ( Doc, Mode(..) )
+import GHC.Utils.Panic.Plain (assert)
import GHC.Serialized
import GHC.LanguageExtensions (Extension)
import GHC.Utils.GlobalVars( unsafeHasPprDebug )
@@ -855,9 +856,10 @@ ppWhenOption f doc = sdocOption f $ \case
False -> empty
{-# INLINE CONLIKE ppUnlessOption #-}
-ppUnlessOption :: IsLine doc => (SDocContext -> Bool) -> doc -> doc
-ppUnlessOption f doc = docWithContext $
- \ctx -> if f ctx then empty else doc
+ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc
+ppUnlessOption f doc = sdocOption f $ \case
+ True -> empty
+ False -> doc
-- | Apply the given colour\/style for the argument.
--
@@ -1040,10 +1042,7 @@ instance Outputable ModuleName where
pprModuleName :: IsLine doc => ModuleName -> doc
pprModuleName (ModuleName nm) =
- docWithContext $ \ctx ->
- if codeStyle (sdocStyle ctx)
- then ztext (zEncodeFS nm)
- else ftext nm
+ docWithStyle (ztext (zEncodeFS nm)) (\_ -> ftext nm)
{-# SPECIALIZE pprModuleName :: ModuleName -> SDoc #-}
{-# SPECIALIZE pprModuleName :: ModuleName -> HLine #-} -- see Note [SPECIALIZE to HDoc]
@@ -1633,6 +1632,7 @@ IsOutput, that allows these combinators to be generic over both variants:
class IsOutput doc where
empty :: doc
docWithContext :: (SDocContext -> doc) -> doc
+ docWithStyle :: doc -> (PprStyle -> SDoc) -> doc
class IsOutput doc => IsLine doc
class (IsOutput doc, IsLine (Line doc)) => IsDoc doc
@@ -1669,13 +1669,22 @@ arguments depending on the type they are instantiated at. They serve as a
difficult to make completely equivalent under both printer implementations.
These operations should generally be avoided, as they can result in surprising
-changes in behavior when the printer implementation is changed. However, in
-certain cases, the alternative is even worse. For example, we use dualLine in
-the implementation of pprUnitId, as the hack we use for printing unit ids
-(see Note [Pretty-printing UnitId] in GHC.Unit) is difficult to adapt to HLine
-and is not necessary for code paths that use it, anyway.
-
-Use these operations wisely. -}
+changes in behavior when the printer implementation is changed.
+Right now, they are used only when outputting debugging comments in
+codegen, as it is difficult to adapt that code to use HLine and not necessary.
+
+Use these operations wisely.
+
+Note [docWithStyle]
+~~~~~~~~~~~~~~~~~~~
+Sometimes when printing, we consult the printing style. This can be done
+with 'docWithStyle c f'. This is similar to 'docWithContext (f . sdocStyle)',
+but:
+* For code style, 'docWithStyle c f' will return 'c'.
+* For other styles, 'docWithStyle c f', will call 'f style', but expect
+ an SDoc rather than doc. This removes the need to write code polymorphic
+ in SDoc and HDoc, since the latter is used only for code style.
+-}
-- | Represents a single line of output that can be efficiently printed directly
-- to a 'System.IO.Handle' (actually a 'BufHandle').
@@ -1700,7 +1709,7 @@ pattern HDoc f <- HDoc' f
{-# COMPLETE HDoc #-}
bPutHDoc :: BufHandle -> SDocContext -> HDoc -> IO ()
-bPutHDoc h ctx (HDoc f) = f ctx h
+bPutHDoc h ctx (HDoc f) = assert (codeStyle (sdocStyle ctx)) (f ctx h)
-- | A superclass for 'IsLine' and 'IsDoc' that provides an identity, 'empty',
-- as well as access to the shared 'SDocContext'.
@@ -1709,6 +1718,7 @@ bPutHDoc h ctx (HDoc f) = f ctx h
class IsOutput doc where
empty :: doc
docWithContext :: (SDocContext -> doc) -> doc
+ docWithStyle :: doc -> (PprStyle -> SDoc) -> doc -- see Note [docWithStyle]
-- | A class of types that represent a single logical line of text, with support
-- for horizontal composition.
@@ -1779,6 +1789,11 @@ instance IsOutput SDoc where
{-# INLINE CONLIKE empty #-}
docWithContext = sdocWithContext
{-# INLINE docWithContext #-}
+ docWithStyle c f = sdocWithContext (\ctx -> let sty = sdocStyle ctx
+ in if codeStyle sty then c
+ else f sty)
+ -- see Note [docWithStyle]
+ {-# INLINE CONLIKE docWithStyle #-}
instance IsLine SDoc where
char c = docToSDoc $ Pretty.char c
@@ -1823,12 +1838,16 @@ instance IsOutput HLine where
{-# INLINE empty #-}
docWithContext f = HLine $ \ctx h -> runHLine (f ctx) ctx h
{-# INLINE CONLIKE docWithContext #-}
+ docWithStyle c _ = c -- see Note [docWithStyle]
+ {-# INLINE CONLIKE docWithStyle #-}
instance IsOutput HDoc where
empty = HDoc (\_ _ -> pure ())
{-# INLINE empty #-}
docWithContext f = HDoc $ \ctx h -> runHDoc (f ctx) ctx h
{-# INLINE CONLIKE docWithContext #-}
+ docWithStyle c _ = c -- see Note [docWithStyle]
+ {-# INLINE CONLIKE docWithStyle #-}
instance IsLine HLine where
char c = HLine (\_ h -> bPutChar h c)
=====================================
m4/fp_settings.m4
=====================================
@@ -10,12 +10,12 @@ AC_DEFUN([FP_SETTINGS],
# See Note [tooldir: How GHC finds mingw on Windows]
mingw_bin_prefix='$$tooldir/mingw/bin/'
SettingsCCompilerCommand="${mingw_bin_prefix}clang.exe"
- SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 -I$$tooldir/mingw/include"
+ SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 -I\$\$tooldir/mingw/include"
SettingsCxxCompilerCommand="${mingw_bin_prefix}clang++.exe"
- SettingsCxxCompilerFlags="$CONF_CXX_OPTS_STAGE2 -I$$tooldir/mingw/include"
- SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2 -L$$tooldir/mingw/lib -L$$tooldir/mingw/x86_64-w64-mingw32/lib"
+ SettingsCxxCompilerFlags="$CONF_CXX_OPTS_STAGE2 -I\$\$tooldir/mingw/include"
+ SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2 -L\$\$tooldir/mingw/lib -L\$\$tooldir/mingw/x86_64-w64-mingw32/lib"
SettingsHaskellCPPCommand="${mingw_bin_prefix}clang.exe"
- SettingsHaskellCPPFlags="$HaskellCPPArgs -I$$tooldir/mingw/include"
+ SettingsHaskellCPPFlags="$HaskellCPPArgs -I\$\$tooldir/mingw/include"
SettingsLdCommand="${mingw_bin_prefix}ld.lld.exe"
SettingsLdFlags=""
# LLD does not support object merging (#21068)
=====================================
rts/sm/Storage.c
=====================================
@@ -1404,7 +1404,7 @@ allocatePinned (Capability *cap, W_ n /*words*/, W_ alignment /*bytes*/, W_ alig
void
dirty_MUT_VAR(StgRegTable *reg, StgMutVar *mvar, StgClosure *old)
{
-#if defined(THREADED_RTS)
+#if !defined(THREADED_RTS)
// This doesn't hold in the threaded RTS as we may race with another thread.
ASSERT(RELAXED_LOAD(&mvar->header.info) == &stg_MUT_VAR_CLEAN_info);
#endif
=====================================
testsuite/tests/simplCore/should_compile/T22502.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+module M where
+
+import GHC.Exts
+import GHC.IO
+
+data T a = MkT !Bool !a
+
+fun :: T a -> IO a
+{-# OPAQUE fun #-}
+fun (MkT _ x) = IO $ \s -> noinline seq# x s
+-- evaluate/seq# should not produce its own eval for x
+-- since it is properly tagged (from a strict field)
+
+-- uses noinline to prevent caseRules from eliding the seq# in Core
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -463,3 +463,4 @@ test('T22459', normal, compile, [''])
test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
test('T22662', normal, compile, [''])
test('T22725', normal, compile, ['-O'])
+test('T22502', normal, compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a79a172258a36305b4af04105b1d8ce0c8c4caaf...d2b9771ce2875bb9a9788bec7e6fbddefe29d856
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a79a172258a36305b4af04105b1d8ce0c8c4caaf...d2b9771ce2875bb9a9788bec7e6fbddefe29d856
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/20230111/50e127a5/attachment-0001.html>
More information about the ghc-commits
mailing list