[Git][ghc/ghc][ghc-9.8] 7 commits: EPA: Incorrect span for LWarnDec GhcPs
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Tue Sep 19 05:12:46 UTC 2023
Ben Gamari pushed to branch ghc-9.8 at Glasgow Haskell Compiler / GHC
Commits:
0f5c21df by Alan Zimmerman at 2023-09-18T16:58:47-04:00
EPA: Incorrect span for LWarnDec GhcPs
The code (from T23465.hs)
{-# WARNInG in "x-c" e "d" #-}
e = e
gives an incorrect span for the LWarnDecl GhcPs
Closes #23892
It also fixes the Test23465/Test23464 mixup
(cherry picked from commit ede3df271a931f3845b5a63fb29654b46bce620d)
- - - - -
190ddace by Simon Peyton Jones at 2023-09-18T17:02:10-04:00
Use correct FunTyFlag in adjustJoinPointType
As the Lint error in #23952 showed, the function adjustJoinPointType
was failing to adjust the FunTyFlag when adjusting the type.
I don't think this caused the seg-fault reported in the ticket,
but it is definitely. This patch fixes it.
It is tricky to come up a small test case; Krzysztof came up with
this one, but it only triggers a failure in GHC 9.6.
(cherry picked from commit 8e05c54a8cb7e5ad2d584fad5b5ad878dd5488b6)
- - - - -
850d7b1e by Ben Gamari at 2023-09-18T17:07:05-04:00
compiler: Fingerprint more code generation flags
Previously our recompilation check was quite inconsistent in its
coverage of non-optimisation code generation flags. Specifically, we
failed to account for most flags that would affect the behavior of
generated code in ways that might affect the result of a program's
execution (e.g. `-feager-blackholing`, `-fstrict-dicts`)
Closes #23369.
(cherry picked from commit d1c92bf3b4b0b07a6a652f8fc31fd7b62465bf71)
- - - - -
3de6e12c by Andreas Klebinger at 2023-09-18T17:11:51-04:00
Profiling: Properly escape characters when using `-pj`.
There are some ways in which unusual characters like quotes or others
can make it into cost centre names. So properly escape these.
Fixes #23924
(cherry picked from commit e5c00092a13f1a8cf53df2469e027012743cf59a)
- - - - -
ad2c402f by Simon Peyton Jones at 2023-09-18T17:12:37-04:00
Tiny refactor
canEtaReduceToArity was only called internally, and always with
two arguments equal to zero. This patch just specialises the
function, and renames it to cantEtaReduceFun.
No change in behaviour.
(cherry picked from commit 236a134eab4c0a3aae30752a3d580c083f4e6b57)
- - - - -
f7c2c493 by Simon Peyton Jones at 2023-09-18T17:13:08-04:00
Fix eta reduction
Issue #23922 showed that GHC was bogusly eta-reducing a join point.
We should never eta-reduce (\x -> j x) to j, if j is a join point.
It is extremly difficult to trigger this bug. It took me 45 mins of
trying to make a small tests case, here immortalised as T23922a.
(cherry picked from commit 6840012e5bb8f5c13e4bf7a4e4cbba0b06420aaa)
- - - - -
0ea59526 by Matthew Pickering at 2023-09-18T17:15:17-04:00
Add -Winconsistent-flags warning
The warning fires when inconsistent command line flags are passed.
For example:
* -dynamic-too and -dynamic
* -dynamic-too on windows
* -O and --interactive
* etc
This is on by default and allows users to control whether the warning is
displayed and whether it should be an error or not.
Fixes #22572
(cherry picked from commit 21a906c28da497c2b8390de75270357a7f80e5a7)
- - - - -
21 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Iface/Recomp/Flags.hs
- compiler/GHC/Parser.y
- compiler/GHC/Types/Var.hs
- docs/users_guide/using-warnings.rst
- rts/ProfilerReportJson.c
- testsuite/tests/printer/Makefile
- − testsuite/tests/printer/Test23464.hs
- + testsuite/tests/printer/Test23465.hs
- testsuite/tests/printer/all.T
- + testsuite/tests/simplCore/should_compile/T23922a.hs
- + testsuite/tests/simplCore/should_compile/T23952.hs
- + testsuite/tests/simplCore/should_compile/T23952a.hs
- testsuite/tests/simplCore/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -87,6 +87,8 @@ import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
+import Data.Maybe( isJust )
+
{-
************************************************************************
* *
@@ -2306,18 +2308,6 @@ This test is made by `ok_fun` in tryEtaReduce.
* `/\a. \x. f @(Maybe a) x --> /\a. f @(Maybe a)`
See Note [Do not eta reduce PAPs] for why we insist on a trivial head.
-2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it
- is always sound to reduce /type lambdas/, thus:
- (/\a -> f a) --> f
- Moreover, we always want to, because it makes RULEs apply more often:
- This RULE: `forall g. foldr (build (/\a -> g a))`
- should match `foldr (build (/\b -> ...something complex...))`
- and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`.
-
- The type checker can insert these eta-expanded versions,
- with both type and dictionary lambdas; hence the slightly
- ad-hoc (all ok_lam bndrs)
-
Of course, eta reduction is not always sound. See Note [Eta reduction soundness]
for when it is.
@@ -2356,7 +2346,7 @@ perform eta reduction on an expression with n leading lambdas `\xs. e xs`
(checked in 'is_eta_reduction_sound' in 'tryEtaReduce', which focuses on the
case where `e` is trivial):
- A. It is sound to eta-reduce n arguments as long as n does not exceed the
+(A) It is sound to eta-reduce n arguments as long as n does not exceed the
`exprArity` of `e`. (Needs Arity analysis.)
This criterion exploits information about how `e` is *defined*.
@@ -2365,7 +2355,7 @@ case where `e` is trivial):
By contrast, it would be *unsound* to eta-reduce 2 args, `\x y. e x y` to `e`:
`e 42` diverges when `(\x y. e x y) 42` does not.
- S. It is sound to eta-reduce n arguments in an evaluation context in which all
+(S) It is sound to eta-reduce n arguments in an evaluation context in which all
calls happen with at least n arguments. (Needs Strictness analysis.)
NB: This treats evaluations like a call with 0 args.
NB: This criterion exploits information about how `e` is *used*.
@@ -2392,23 +2382,42 @@ case where `e` is trivial):
See Note [Eta reduction based on evaluation context] for the implementation
details. This criterion is tested extensively in T21261.
- R. Note [Eta reduction in recursive RHSs] tells us that we should not
+(R) Note [Eta reduction in recursive RHSs] tells us that we should not
eta-reduce `f` in its own RHS and describes our fix.
There we have `f = \x. f x` and we should not eta-reduce to `f=f`. Which
might change a terminating program (think @f `seq` e@) to a non-terminating
one.
- E. (See fun_arity in tryEtaReduce.) As a perhaps special case on the
+(E) (See fun_arity in tryEtaReduce.) As a perhaps special case on the
boundary of (A) and (S), when we know that a fun binder `f` is in
WHNF, we simply assume it has arity 1 and apply (A). Example:
g f = f `seq` \x. f x
Here it's sound eta-reduce `\x. f x` to `f`, because `f` can't be bottom
after the `seq`. This turned up in #7542.
+ T. If the binders are all type arguments, it's always safe to eta-reduce,
+ regardless of the arity of f.
+ /\a b. f @a @b --> f
+
+2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it
+ is always sound to reduce /type lambdas/, thus:
+ (/\a -> f a) --> f
+ Moreover, we always want to, because it makes RULEs apply more often:
+ This RULE: `forall g. foldr (build (/\a -> g a))`
+ should match `foldr (build (/\b -> ...something complex...))`
+ and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`.
+
+ More debatably, we extend this to dictionary arguments too, because the type
+ checker can insert these eta-expanded versions, with both type and dictionary
+ lambdas; hence the slightly ad-hoc (all ok_lam bndrs). That is, we eta-reduce
+ \(d::Num a). f d --> f
+ regardless of f's arity. Its not clear whether or not this is important, and
+ it is not in general sound. But that's the way it is right now.
+
And here are a few more technical criteria for when it is *not* sound to
eta-reduce that are specific to Core and GHC:
- L. With linear types, eta-reduction can break type-checking:
+(L) With linear types, eta-reduction can break type-checking:
f :: A ⊸ B
g :: A -> B
g = \x. f x
@@ -2416,13 +2425,13 @@ eta-reduce that are specific to Core and GHC:
complain that g and f don't have the same type. NB: Not unsound in the
dynamic semantics, but unsound according to the static semantics of Core.
- J. We may not undersaturate join points.
+(J) We may not undersaturate join points.
See Note [Invariants on join points] in GHC.Core, and #20599.
- B. We may not undersaturate functions with no binding.
+(B) We may not undersaturate functions with no binding.
See Note [Eta expanding primops].
- W. We may not undersaturate StrictWorkerIds.
+(W) We may not undersaturate StrictWorkerIds.
See Note [CBV Function Ids] in GHC.Types.Id.Info.
Here is a list of historic accidents surrounding unsound eta-reduction:
@@ -2666,20 +2675,25 @@ tryEtaReduce rec_ids bndrs body eval_sd
ok_fun (App fun (Type {})) = ok_fun fun
ok_fun (Cast fun _) = ok_fun fun
ok_fun (Tick _ expr) = ok_fun expr
- ok_fun (Var fun_id) = is_eta_reduction_sound fun_id || all ok_lam bndrs
+ ok_fun (Var fun_id) = is_eta_reduction_sound fun_id
ok_fun _fun = False
---------------
-- See Note [Eta reduction soundness], this is THE place to check soundness!
- is_eta_reduction_sound fun =
- -- Don't eta-reduce in fun in its own recursive RHSs
- not (fun `elemUnVarSet` rec_ids) -- criterion (R)
- -- Check that eta-reduction won't make the program stricter...
- && (fun_arity fun >= incoming_arity -- criterion (A) and (E)
- || all_calls_with_arity incoming_arity) -- criterion (S)
- -- ... and that the function can be eta reduced to arity 0
- -- without violating invariants of Core and GHC
- && canEtaReduceToArity fun 0 0 -- criteria (L), (J), (W), (B)
+ is_eta_reduction_sound fun
+ | fun `elemUnVarSet` rec_ids -- Criterion (R)
+ = False -- Don't eta-reduce in fun in its own recursive RHSs
+
+ | cantEtaReduceFun fun -- Criteria (L), (J), (W), (B)
+ = False -- Function can't be eta reduced to arity 0
+ -- without violating invariants of Core and GHC
+
+ | otherwise
+ = -- Check that eta-reduction won't make the program stricter...
+ fun_arity fun >= incoming_arity -- Criterion (A) and (E)
+ || all_calls_with_arity incoming_arity -- Criterion (S)
+ || all ok_lam bndrs -- Criterion (T)
+
all_calls_with_arity n = isStrict (fst $ peelManyCalls n eval_sd)
-- See Note [Eta reduction based on evaluation context]
@@ -2729,19 +2743,18 @@ tryEtaReduce rec_ids bndrs body eval_sd
ok_arg _ _ _ _ = Nothing
--- | Can we eta-reduce the given function to the specified arity?
+-- | Can we eta-reduce the given function
-- See Note [Eta reduction soundness], criteria (B), (J), (W) and (L).
-canEtaReduceToArity :: Id -> JoinArity -> Arity -> Bool
-canEtaReduceToArity fun dest_join_arity dest_arity =
- not $
- hasNoBinding fun -- (B)
+cantEtaReduceFun :: Id -> Bool
+cantEtaReduceFun fun
+ = hasNoBinding fun -- (B)
-- Don't undersaturate functions with no binding.
- || ( isJoinId fun && dest_join_arity < idJoinArity fun ) -- (J)
+ || isJoinId fun -- (J)
-- Don't undersaturate join points.
-- See Note [Invariants on join points] in GHC.Core, and #20599
- || ( dest_arity < idCbvMarkArity fun ) -- (W)
+ || (isJust (idCbvMarks_maybe fun)) -- (W)
-- Don't undersaturate StrictWorkerIds.
-- See Note [CBV Function Ids] in GHC.Types.Id.Info.
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -58,30 +58,34 @@ import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Rules.Config ( RuleOpts(..) )
import GHC.Core
import GHC.Core.Utils
-import GHC.Core.Multiplicity ( scaleScaled )
import GHC.Core.Unfold
import GHC.Core.TyCo.Subst (emptyIdSubstEnv)
+import GHC.Core.Multiplicity( Scaled(..), mkMultMul )
+import GHC.Core.Make ( mkWildValBinder, mkCoreLet )
+import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, substCo
+ , extendTvSubst, extendCvSubst )
+import qualified GHC.Core.Coercion as Coercion
+import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr )
+import qualified GHC.Core.Type as Type
+
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
+import GHC.Types.Id as Id
+import GHC.Types.Basic
+import GHC.Types.Unique.FM ( pprUniqFM )
+
import GHC.Data.OrdList
import GHC.Data.Graph.UnVar
-import GHC.Types.Id as Id
-import GHC.Core.Make ( mkWildValBinder, mkCoreLet )
+
import GHC.Builtin.Types
-import qualified GHC.Core.Type as Type
-import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, substCo
- , extendTvSubst, extendCvSubst )
-import qualified GHC.Core.Coercion as Coercion
-import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr )
import GHC.Platform ( Platform )
-import GHC.Types.Basic
+
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
-import GHC.Types.Unique.FM ( pprUniqFM )
import Data.List ( intersperse, mapAccumL )
@@ -1171,21 +1175,34 @@ adjustJoinPointType mult new_res_ty join_id
= assert (isJoinId join_id) $
setIdType join_id new_join_ty
where
- orig_ar = idJoinArity join_id
- orig_ty = idType join_id
-
- new_join_ty = go orig_ar orig_ty :: Type
+ join_arity = idJoinArity join_id
+ orig_ty = idType join_id
+ res_torc = typeTypeOrConstraint new_res_ty :: TypeOrConstraint
+
+ new_join_ty = go join_arity orig_ty :: Type
+
+ go :: JoinArity -> Type -> Type
+ go n ty
+ | n == 0
+ = new_res_ty
+
+ | Just (arg_bndr, body_ty) <- splitPiTy_maybe ty
+ , let body_ty' = go (n-1) body_ty
+ = case arg_bndr of
+ Named b -> mkForAllTy b body_ty'
+ Anon (Scaled arg_mult arg_ty) af -> mkFunTy af' arg_mult' arg_ty body_ty'
+ where
+ -- Using "!": See Note [Bangs in the Simplifier]
+ -- mkMultMul: see Note [Scaling join point arguments]
+ !arg_mult' = arg_mult `mkMultMul` mult
+
+ -- the new_res_ty might be ConstraintLike while the original
+ -- one was TypeLike. So we may need to adjust the FunTyFlag.
+ -- (see #23952)
+ !af' = mkFunTyFlag (funTyFlagArgTypeOrConstraint af) res_torc
- go 0 _ = new_res_ty
- go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty
- = mkPiTy (scale_bndr arg_bndr) $
- go (n-1) res_ty
- | otherwise
- = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty)
-
- -- See Note [Bangs in the Simplifier]
- scale_bndr (Anon t af) = (Anon $! (scaleScaled mult t)) af
- scale_bndr b@(Named _) = b
+ | otherwise
+ = pprPanic "adjustJoinPointType" (ppr join_arity <+> ppr orig_ty)
{- Note [Scaling join point arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -2554,12 +2554,12 @@ Here are the key kinding rules for types
-- in GHC.Builtin.Types.Prim
torc is TYPE or CONSTRAINT
- ty : torc rep
+ ty : body_torc rep
ki : Type
`a` is a type variable
`a` is not free in rep
(FORALL1) -----------------------
- forall (a::ki). ty : torc rep
+ forall (a::ki). ty : body_torc rep
torc is TYPE or CONSTRAINT
ty : body_torc rep
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -5,6 +5,7 @@ module GHC.Driver.Flags
, GeneralFlag(..)
, Language(..)
, optimisationFlags
+ , codeGenFlags
-- * Warnings
, WarningGroup(..)
@@ -484,15 +485,11 @@ data GeneralFlag
| Opt_G_NoOptCoercion
deriving (Eq, Show, Enum)
--- Check whether a flag should be considered an "optimisation flag"
--- for purposes of recompilation avoidance (see
--- Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags). Being listed here is
--- not a guarantee that the flag has no other effect. We could, and
--- perhaps should, separate out the flags that have some minor impact on
--- program semantics and/or error behavior (e.g., assertions), but
--- then we'd need to go to extra trouble (and an additional flag)
--- to allow users to ignore the optimisation level even though that
--- means ignoring some change.
+-- | The set of flags which affect optimisation for the purposes of
+-- recompilation avoidance. Specifically, these include flags which
+-- affect code generation but not the semantics of the program.
+--
+-- See Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags)
optimisationFlags :: EnumSet GeneralFlag
optimisationFlags = EnumSet.fromList
[ Opt_CallArity
@@ -524,16 +521,12 @@ optimisationFlags = EnumSet.fromList
, Opt_EnableRewriteRules
, Opt_RegsGraph
, Opt_RegsIterative
- , Opt_PedanticBottoms
, Opt_LlvmTBAA
- , Opt_LlvmFillUndefWithGarbage
, Opt_IrrefutableTuples
, Opt_CmmSink
, Opt_CmmElimCommonBlocks
, Opt_AsmShortcutting
- , Opt_OmitYields
, Opt_FunToThunk
- , Opt_DictsStrict
, Opt_DmdTxDictSel
, Opt_Loopification
, Opt_CfgBlocklayout
@@ -542,8 +535,47 @@ optimisationFlags = EnumSet.fromList
, Opt_WorkerWrapper
, Opt_WorkerWrapperUnlift
, Opt_SolveConstantDicts
+ ]
+
+-- | The set of flags which affect code generation and can change a program's
+-- runtime behavior (other than performance). These include flags which affect:
+--
+-- * user visible debugging information (e.g. info table provenance)
+-- * the ability to catch runtime errors (e.g. -fignore-asserts)
+-- * the runtime result of the program (e.g. -fomit-yields)
+-- * which code or interface file declarations are emitted
+--
+-- We also considered placing flags which affect asympototic space behavior
+-- (e.g. -ffull-laziness) however this would mean that changing optimisation
+-- levels would trigger recompilation even with -fignore-optim-changes,
+-- regressing #13604.
+--
+-- Also, arguably Opt_IgnoreAsserts should be here as well; however, we place
+-- it instead in 'optimisationFlags' since it is implied by @-O[12]@ and
+-- therefore would also break #13604.
+--
+-- See #23369.
+codeGenFlags :: EnumSet GeneralFlag
+codeGenFlags = EnumSet.fromList
+ [ -- Flags that affect runtime result
+ Opt_EagerBlackHoling
+ , Opt_ExcessPrecision
+ , Opt_DictsStrict
+ , Opt_PedanticBottoms
+ , Opt_OmitYields
+
+ -- Flags that affect generated code
+ , Opt_ExposeAllUnfoldings
+ , Opt_NoTypeableBinds
+
+ -- Flags that affect catching of runtime errors
, Opt_CatchNonexhaustiveCases
- , Opt_IgnoreAsserts
+ , Opt_LlvmFillUndefWithGarbage
+ , Opt_DoTagInferenceChecks
+
+ -- Flags that affect debugging information
+ , Opt_DistinctConstructorTables
+ , Opt_InfoTableMap
]
data WarningFlag =
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -66,6 +66,7 @@ module GHC.Driver.Session (
makeDynFlagsConsistent,
positionIndependent,
optimisationFlags,
+ codeGenFlags,
setFlagsFromEnvFile,
pprDynFlagsDiff,
flagSpecOf,
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1220,7 +1220,7 @@ type instance XXWarnDecl (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
=> Outputable (WarnDecls (GhcPass p)) where
ppr (Warnings ext decls)
- = ftext src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
+ = ftext src <+> vcat (punctuate semi (map ppr decls)) <+> text "#-}"
where src = case ghcPass @p of
GhcPs | (_, SourceText src) <- ext -> src
GhcRn | SourceText src <- ext -> src
=====================================
compiler/GHC/Iface/Recomp/Flags.hs
=====================================
@@ -67,7 +67,10 @@ fingerprintDynFlags hsc_env this_mod nameio =
ticky =
map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag]
- flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel, callerCcFilters))
+ -- Other flags which affect code generation
+ codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags)
+
+ flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters))
in -- pprTrace "flags" (ppr flags) $
computeFingerprint nameio flags
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2010,8 +2010,8 @@ warnings :: { OrdList (LWarnDecl GhcPs) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
warning :: { OrdList (LWarnDecl GhcPs) }
: warning_category namelist strings
- {% fmap unitOL $ acsA (\cs -> sLL $2 $>
- (Warning (EpAnn (glR $2) (fst $ unLoc $3) cs) (unLoc $2)
+ {% fmap unitOL $ acsA (\cs -> L (comb3M $1 $2 $3)
+ (Warning (EpAnn (glMR $1 $2) (fst $ unLoc $3) cs) (unLoc $2)
(WarningTxt $1 (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
deprecations :: { OrdList (LWarnDecl GhcPs) }
@@ -4114,6 +4114,12 @@ comb3N :: Located a -> Located b -> LocatedN c -> SrcSpan
comb3N a b c = a `seq` b `seq` c `seq`
combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))
+comb3M :: Maybe (Located a) -> Located b -> Located c -> SrcSpan
+comb3M (Just a) b c = a `seq` b `seq` c `seq`
+ combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
+comb3M Nothing b c = b `seq` c `seq`
+ (combineSrcSpans (getLoc b) (getLoc c))
+
comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan
comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
(combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
@@ -4344,6 +4350,10 @@ glN = getLocA
glR :: Located a -> Anchor
glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor
+glMR :: Maybe (Located a) -> Located b -> Anchor
+glMR (Just la) _ = glR la
+glMR _ la = glR la
+
glAA :: Located a -> EpaLocation
glAA = srcSpan2e . getLoc
@@ -4584,5 +4594,4 @@ adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments))
-> Located (HsLocalBinds GhcPs, EpAnnComments)
adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments)
adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)
-
}
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -75,7 +75,7 @@ module GHC.Types.Var (
mkFunTyFlag, visArg, invisArg,
visArgTypeLike, visArgConstraintLike,
invisArgTypeLike, invisArgConstraintLike,
- funTyFlagResultTypeOrConstraint,
+ funTyFlagArgTypeOrConstraint, funTyFlagResultTypeOrConstraint,
TypeOrConstraint(..), -- Re-export this: it's an argument of FunTyFlag
-- * PiTyBinder
@@ -589,6 +589,12 @@ isFUNArg :: FunTyFlag -> Bool
isFUNArg FTF_T_T = True
isFUNArg _ = False
+funTyFlagArgTypeOrConstraint :: FunTyFlag -> TypeOrConstraint
+-- Whether it /takes/ a type or a constraint
+funTyFlagArgTypeOrConstraint FTF_T_T = TypeLike
+funTyFlagArgTypeOrConstraint FTF_T_C = TypeLike
+funTyFlagArgTypeOrConstraint _ = ConstraintLike
+
funTyFlagResultTypeOrConstraint :: FunTyFlag -> TypeOrConstraint
-- Whether it /returns/ a type or a constraint
funTyFlagResultTypeOrConstraint FTF_T_T = TypeLike
=====================================
docs/users_guide/using-warnings.rst
=====================================
@@ -2511,6 +2511,20 @@ of ``-W(no-)*``.
issued. Another example is :ghc-flag:`-dynamic` is ignored when :ghc-flag:`-dynamic-too`
is passed.
+.. ghc-flag:: -Winconsistent-flags
+ :shortdesc: warn when command line options are inconsistent in some way.
+ :type: dynamic
+ :reverse: -Wno-inconsistent-flags
+
+ :since: 9.8.1
+ :default: on
+
+ Warn when command line options are inconsistent in some way.
+
+ For example, when using GHCi, optimisation flags are ignored and a warning is
+ issued. Another example is :ghc-flag:`-dynamic` is ignored when :ghc-flag:`-dynamic-too`
+ is passed.
+
If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice.
It turns on heavyweight intra-pass sanity-checking within GHC. (It checks GHC's
sanity, not yours.)
=====================================
rts/ProfilerReportJson.c
=====================================
@@ -17,36 +17,178 @@
#include <string.h>
-// I don't think this code is all that perf critical.
-// So we just allocate a new buffer each time around.
+// Including zero byte
+static size_t escaped_size(char const* str)
+{
+ size_t escaped_size = 0;
+ for (; *str != '\0'; str++) {
+ const unsigned char c = *str;
+ switch (c)
+ {
+ // quotation mark (0x22)
+ case '"':
+ {
+ escaped_size += 2;
+ break;
+ }
+
+ case '\\':
+ {
+ escaped_size += 2;
+ break;
+ }
+
+ // backspace (0x08)
+ case '\b':
+ {
+ escaped_size += 2;
+ break;
+ }
+
+ // formfeed (0x0c)
+ case '\f':
+ {
+ escaped_size += 2;
+ break;
+ }
+
+ // newline (0x0a)
+ case '\n':
+ {
+ escaped_size += 2;
+ break;
+ }
+
+ // carriage return (0x0d)
+ case '\r':
+ {
+ escaped_size += 2;
+ break;
+ }
+
+ // horizontal tab (0x09)
+ case '\t':
+ {
+ escaped_size += 2;
+ break;
+ }
+
+ default:
+ {
+ if (c <= 0x1f)
+ {
+ // print character c as \uxxxx
+ escaped_size += 6;
+ }
+ else
+ {
+ escaped_size ++;
+ }
+ break;
+ }
+ }
+ }
+ escaped_size++; // null byte
+
+ return escaped_size;
+}
+
static void escapeString(char const* str, char **buf)
{
char *out;
- size_t req_size; //Max required size for decoding.
- size_t in_size; //Input size, including zero.
-
- in_size = strlen(str) + 1;
- // The strings are generally small and short
- // lived so should be ok to just double the size.
- req_size = in_size * 2;
- out = stgMallocBytes(req_size, "writeCCSReportJson");
- *buf = out;
- // We provide an outputbuffer twice the size of the input,
- // and at worse double the output size. So we can skip
- // length checks.
+ size_t out_size; //Max required size for decoding.
+ size_t pos = 0;
+
+ out_size = escaped_size(str); //includes trailing zero byte
+ out = stgMallocBytes(out_size, "writeCCSReportJson");
for (; *str != '\0'; str++) {
- char c = *str;
- if (c == '\\') {
- *out = '\\'; out++;
- *out = '\\'; out++;
- } else if (c == '\n') {
- *out = '\\'; out++;
- *out = 'n'; out++;
- } else {
- *out = c; out++;
- }
+ const unsigned char c = *str;
+ switch (c)
+ {
+ // quotation mark (0x22)
+ case '"':
+ {
+ out[pos] = '\\';
+ out[pos + 1] = '"';
+ pos += 2;
+ break;
+ }
+
+ // reverse solidus (0x5c)
+ case '\\':
+ {
+ out[pos] = '\\';
+ out[pos+1] = '\\';
+ pos += 2;
+ break;
+ }
+
+ // backspace (0x08)
+ case '\b':
+ {
+ out[pos] = '\\';
+ out[pos + 1] = 'b';
+ pos += 2;
+ break;
+ }
+
+ // formfeed (0x0c)
+ case '\f':
+ {
+ out[pos] = '\\';
+ out[pos + 1] = 'f';
+ pos += 2;
+ break;
+ }
+
+ // newline (0x0a)
+ case '\n':
+ {
+ out[pos] = '\\';
+ out[pos + 1] = 'n';
+ pos += 2;
+ break;
+ }
+
+ // carriage return (0x0d)
+ case '\r':
+ {
+ out[pos] = '\\';
+ out[pos + 1] = 'r';
+ pos += 2;
+ break;
+ }
+
+ // horizontal tab (0x09)
+ case '\t':
+ {
+ out[pos] = '\\';
+ out[pos + 1] = 't';
+ pos += 2;
+ break;
+ }
+
+ default:
+ {
+ if (c <= 0x1f)
+ {
+ // print character c as \uxxxx
+ out[pos] = '\\';
+ sprintf(&out[pos + 1], "u%04x", (int)c);
+ pos += 6;
+ }
+ else
+ {
+ // all other characters are added as-is
+ out[pos++] = c;
+ }
+ break;
+ }
+ }
}
- *out = '\0';
+ out[pos++] = '\0';
+ assert(pos == out_size);
+ *buf = out;
}
static void
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -791,13 +791,13 @@ Test22771:
$(CHECK_PPR) $(LIBDIR) Test22771.hs
$(CHECK_EXACT) $(LIBDIR) Test22771.hs
-.PHONY: Test23464
+.PHONY: Test23465
Test23465:
- $(CHECK_PPR) $(LIBDIR) Test23464.hs
- $(CHECK_EXACT) $(LIBDIR) Test23464.hs
+ $(CHECK_PPR) $(LIBDIR) Test23465.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23465.hs
.PHONY: Test23887
-Test23465:
+Test23887:
$(CHECK_PPR) $(LIBDIR) Test23887.hs
$(CHECK_EXACT) $(LIBDIR) Test23887.hs
=====================================
testsuite/tests/printer/Test23464.hs deleted
=====================================
@@ -1,4 +0,0 @@
-module T23465 {-# WaRNING in "x-a" "b" #-} where
-
-{-# WARNInG in "x-c" e "d" #-}
-e = e
=====================================
testsuite/tests/printer/Test23465.hs
=====================================
@@ -0,0 +1,14 @@
+module Test23465 {-# WaRNING in "x-a" "b" #-} where
+
+{-# WARNInG in "x-c" e "d" #-}
+e = e
+
+{-# WARNInG
+ in "x-f" f "fw" ;
+ in "x-f" g "gw"
+#-}
+f = f
+g = g
+
+{-# WARNinG h "hw" #-}
+h = h
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -190,6 +190,6 @@ test('T20531_red_ticks', extra_files(['T20531_defs.hs']), ghci_script, ['T20531_
test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
test('Test22765', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22765'])
test('Test22771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22771'])
-test('Test23464', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23464'])
-test('Test23887', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23887'])
test('Test23885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23885'])
+test('Test23465', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23465'])
+test('Test23887', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23887'])
=====================================
testsuite/tests/simplCore/should_compile/T23922a.hs
=====================================
@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -O -fworker-wrapper-cbv -dcore-lint -Wno-simplifiable-class-constraints #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- It is very tricky to tickle this bug in 9.6/9.8!
+-- (It came up in a complicated program due to Mikolaj.)
+--
+-- We need a join point, with only dictionary arguments
+-- whose RHS is just another join-point application, which
+-- can be eta-reduced.
+--
+-- The -fworker-wrapper-cbv makes a wrapper whose RHS looks eta-reducible.
+
+module T23922a where
+
+f :: forall a. Eq a => [a] -> Bool
+f x = let {-# NOINLINE j #-}
+ j :: Eq [a] => Bool
+ j = x==x
+ in j
=====================================
testsuite/tests/simplCore/should_compile/T23952.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- The Lint failure in in #23952 is very hard to trigger.
+-- The test case fails with GHC 9.6, but not 9.4, 9.8, or HEAD.
+-- But still, better something than nothing.
+
+module T23952 where
+
+import T23952a
+import Data.Proxy
+import Data.Kind
+
+type Filter :: Type -> Type
+data Filter ty = FilterWithMain Int Bool
+
+new :: forall n . Eq n => () -> Filter n
+{-# INLINABLE new #-}
+new _ = toFilter
+
+class FilterDSL x where
+ toFilter :: Filter x
+
+instance Eq c => FilterDSL c where
+ toFilter = case (case fromRep cid == cid of
+ True -> FilterWithMain cid False
+ False -> FilterWithMain cid True
+ ) of FilterWithMain c x -> FilterWithMain (c+1) (not x)
+ where cid :: Int
+ cid = 3
+ {-# INLINE toFilter #-}
=====================================
testsuite/tests/simplCore/should_compile/T23952a.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE DerivingVia #-}
+module T23952a where
+
+class AsRep rep a where
+ fromRep :: rep -> a
+
+newtype ViaIntegral a = ViaIntegral a
+ deriving newtype (Eq, Ord, Real, Enum, Num, Integral)
+
+instance forall a n . (Integral a, Integral n, Eq a) => AsRep a (ViaIntegral n) where
+ fromRep r = fromIntegral $ r + 2
+ {-# INLINE fromRep #-}
+
+deriving via (ViaIntegral Int) instance (Integral r) => AsRep r Int
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -493,3 +493,5 @@ test('T23491d', [extra_files(['T23491.hs']), grep_errmsg(r'Static argument')], m
test('T23272', [only_ways(['ghci']), extra_hc_opts('-fno-unoptimized-core-for-interpreter -O')], ghci_script, ['T23272.script'])
test('T23567', [extra_files(['T23567A.hs'])], multimod_compile, ['T23567', '-O -v0'])
test('T23938', [extra_files(['T23938A.hs'])], multimod_compile, ['T23938', '-O -v0'])
+test('T23952', [extra_files(['T23952a.hs'])], multimod_compile, ['T23952', '-v0 -O'])
+test('T23922a', normal, compile, ['-O'])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -614,8 +614,18 @@ markEpAnnLMS' (EpAnn anc a cs) l kw (Just str) = do
return (AddEpAnn kw' r')
| otherwise = return (AddEpAnn kw' r)
+
-- ---------------------------------------------------------------------
+markLToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
+ => Located (HsToken tok) -> EP w m (Located (HsToken tok))
+markLToken (L (RealSrcSpan aa mb) t) = do
+ epaLoc'<- printStringAtAA (EpaSpan aa mb) (symbolVal (Proxy @tok))
+ case epaLoc' of
+ EpaSpan aa' mb' -> return (L (RealSrcSpan aa' mb') t)
+ _ -> return (L (RealSrcSpan aa mb ) t)
+markLToken (L lt t) = return (L lt t)
+
markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
=> LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs)
markToken (L NoTokenLoc t) = return (L NoTokenLoc t)
@@ -1415,11 +1425,13 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
exact (L (SrcSpanAnn an l) (WarningTxt mb_cat (L la src) ws)) = do
an0 <- markAnnOpenP an src "{-# WARNING"
+ mb_cat' <- markAnnotated mb_cat
an1 <- markEpAnnL an0 lapr_rest AnnOpenS
ws' <- markAnnotated ws
an2 <- markEpAnnL an1 lapr_rest AnnCloseS
an3 <- markAnnCloseP an2
- return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat (L la src) ws'))
+ return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat' (L la src) ws'))
+
exact (L (SrcSpanAnn an l) (DeprecatedTxt (L ls src) ws)) = do
an0 <- markAnnOpenP an src "{-# DEPRECATED"
@@ -1429,6 +1441,25 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
an3 <- markAnnCloseP an2
return (L (SrcSpanAnn an3 l) (DeprecatedTxt (L ls src) ws'))
+instance ExactPrint InWarningCategory where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
+
+ exact (InWarningCategory tkIn source (L l wc)) = do
+ tkIn' <- markLToken tkIn
+ L _ (_,wc') <- markAnnotated (L l (source, wc))
+ return (InWarningCategory tkIn' source (L l wc'))
+
+instance ExactPrint (SourceText, WarningCategory) where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
+
+ exact (st, WarningCategory wc) = do
+ case st of
+ NoSourceText -> printStringAdvance $ "\"" ++ (unpackFS wc) ++ "\""
+ SourceText src -> printStringAdvance $ (unpackFS src)
+ return (st, WarningCategory wc)
+
-- ---------------------------------------------------------------------
instance ExactPrint (ImportDecl GhcPs) where
@@ -1750,19 +1781,20 @@ instance ExactPrint (WarnDecl GhcPs) where
getAnnotationEntry (Warning an _ _) = fromAnn an
setAnnotationAnchor (Warning an a b) anc cs = Warning (setAnchorEpa an anc cs) a b
- exact (Warning an lns txt) = do
+ exact (Warning an lns (WarningTxt mb_cat src ls )) = do
+ mb_cat' <- markAnnotated mb_cat
lns' <- markAnnotated lns
an0 <- markEpAnnL an lidl AnnOpenS -- "["
- txt' <-
- case txt of
- WarningTxt mb_cat src ls -> do
- ls' <- markAnnotated ls
- return (WarningTxt mb_cat src ls')
- DeprecatedTxt src ls -> do
- ls' <- markAnnotated ls
- return (DeprecatedTxt src ls')
+ ls' <- markAnnotated ls
+ an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"
+ return (Warning an1 lns' (WarningTxt mb_cat' src ls'))
+
+ exact (Warning an lns (DeprecatedTxt src ls)) = do
+ lns' <- markAnnotated lns
+ an0 <- markEpAnnL an lidl AnnOpenS -- "["
+ ls' <- markAnnotated ls
an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"
- return (Warning an1 lns' txt')
+ return (Warning an1 lns' (DeprecatedTxt src ls'))
-- ---------------------------------------------------------------------
@@ -1785,7 +1817,6 @@ instance ExactPrint FastString where
-- exact fs = printStringAdvance (show (unpackFS fs))
exact fs = printStringAdvance (unpackFS fs) >> return fs
-
-- ---------------------------------------------------------------------
instance ExactPrint (RuleDecls GhcPs) where
@@ -3130,7 +3161,6 @@ instance (ExactPrint body)
-- ---------------------------------------------------------------------
--- instance ExactPrint (HsRecUpdField GhcPs q) where
instance (ExactPrint (LocatedA body))
=> ExactPrint (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where
getAnnotationEntry x = fromAnn (hfbAnn x)
=====================================
utils/check-exact/Main.hs
=====================================
@@ -206,7 +206,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_buil
-- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
-- "../../testsuite/tests/printer/Test22771.hs" Nothing
- "../../testsuite/tests/typecheck/should_fail/T22560_fail_c.hs" Nothing
+ "../../testsuite/tests/printer/Test23465.hs" Nothing
-- cloneT does not need a test, function can be retired
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13ccbdc3820f3d2d220dab2784a587fd4c5df01f...0ea59526dd23a675591a5289dcce222558c2ed3c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13ccbdc3820f3d2d220dab2784a587fd4c5df01f...0ea59526dd23a675591a5289dcce222558c2ed3c
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/20230919/f4389687/attachment-0001.html>
More information about the ghc-commits
mailing list