[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Fix tyvar scoping within class SPECIALISE pragmas
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Feb 8 20:42:37 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9ee761bf by sheaf at 2023-02-08T14:40:40-05:00
Fix tyvar scoping within class SPECIALISE pragmas
Type variables from class/instance headers scope over class/instance
method type signatures, but DO NOT scope over the type signatures in
SPECIALISE and SPECIALISE instance pragmas.
The logic in GHC.Rename.Bind.rnMethodBinds correctly accounted for
SPECIALISE inline pragmas, but forgot to apply the same treatment
to method SPECIALISE pragmas, which lead to a Core Lint failure with
an out-of-scope type variable. This patch makes sure we apply the same
logic for both cases.
Fixes #22913
- - - - -
7eac2468 by Matthew Pickering at 2023-02-08T14:41:17-05:00
Revert "Don't keep exit join points so much"
This reverts commit caced75765472a1a94453f2e5a439dba0d04a265.
It seems the patch "Don't keep exit join points so much" is causing
wide-spread regressions in the bytestring library benchmarks. If I
revert it then the 9.6 numbers are better on average than 9.4.
See https://gitlab.haskell.org/ghc/ghc/-/issues/22893#note_479525
-------------------------
Metric Decrease:
MultiComponentModules
MultiComponentModulesRecomp
MultiLayerModules
MultiLayerModulesRecomp
MultiLayerModulesTH_Make
T12150
T13386
T13719
T21839c
T3294
parsing001
-------------------------
- - - - -
c803e8d7 by Cheng Shao at 2023-02-08T15:42:10-05:00
testsuite: remove config.use_threads
This patch simplifies the testsuite driver by removing the use_threads
config field. It's just a degenerate case of threads=1.
- - - - -
274d24da by Cheng Shao at 2023-02-08T15:42:10-05:00
testsuite: use concurrent.futures.ThreadPoolExecutor in the driver
The testsuite driver used to create one thread per test case, and
explicitly use semaphore and locks for rate limiting and
synchronization. This is a bad practice in any language, and
occasionally may result in livelock conditions (e.g. #22889). This
patch uses concurrent.futures.ThreadPoolExecutor for scheduling test
case runs, which is simpler and more robust.
- - - - -
d5b5c07c by Alan Zimmerman at 2023-02-08T15:42:10-05:00
EPA: Comment between module and where should be in header comments
Do not apply the heuristic to associate a comment with a prior
declaration for the first declaration in the file.
Closes #22919
- - - - -
26 changed files:
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Rename/Bind.hs
- testsuite/driver/runtests.py
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/driver/testutil.py
- + testsuite/tests/ghc-api/exactprint/T22919.hs
- + testsuite/tests/ghc-api/exactprint/T22919.stderr
- testsuite/tests/ghc-api/exactprint/Test20239.stderr
- testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
- testsuite/tests/ghc-api/exactprint/all.T
- testsuite/tests/parser/should_compile/DumpParsedAstComments.hs
- testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
- + testsuite/tests/rename/should_compile/T22913.hs
- testsuite/tests/rename/should_compile/all.T
- − testsuite/tests/simplCore/should_compile/T21148.hs
- − testsuite/tests/simplCore/should_compile/T21148.stderr
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/stranal/should_compile/T21128.hs
- testsuite/tests/stranal/should_compile/T21128.stderr
Changes:
=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -433,7 +433,6 @@ inlining.
Exit join points, recognizable using `isExitJoinId` are join points with an
occurrence in a recursive group, and can be recognized (after the occurrence
analyzer ran!) using `isExitJoinId`.
-
This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`,
because the lambdas of a non-recursive join point are not considered for
`occ_in_lam`. For example, in the following code, `j1` is /not/ marked
@@ -447,29 +446,6 @@ To prevent inlining, we check for isExitJoinId
* In `simplLetUnfolding` we simply give exit join points no unfolding, which
prevents inlining in `postInlineUnconditionally` and call sites.
-But see Note [Be selective about not-inlining exit join points]
-
-Note [Be selective about not-inlining exit join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we follow "do not inline exit join points" mantra throughout,
-some bad things happen.
-
-* We can lose CPR information: see #21148
-
-* We get useless clutter (#22084) that
- - makes the program bigger (including duplicated code #20739), and
- - adds extra jumps (and maybe stack saves) at runtime
-
-So instead we follow "do not inline exit join points" for a /single run/
-of the simplifier, right after Exitification. That should give a
-sufficient chance for used-once things to inline, but subsequent runs
-will inline them back in. (Annoyingly, as things stand, only with -O2
-is there a subsequent run, but that might change, and it's not a huge
-deal anyway.)
-
-This is controlled by the Simplifier's sm_keep_exits flag; see
-GHC.Core.Opt.Pipeline.
-
Note [Placement of the exitification pass]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
I (Joachim) experimented with multiple positions for the Exitification pass in
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -15,7 +15,7 @@ import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
import GHC.Driver.Env
import GHC.Driver.Config.Core.Lint ( endPass )
import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )
-import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode )
+import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode )
import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts )
import GHC.Driver.Config.Core.Rules ( initRuleOpts )
import GHC.Platform.Ways ( hasWay, Way(WayProf) )
@@ -28,7 +28,6 @@ import GHC.Core.Utils ( dumpIdInfoOfProgram )
import GHC.Core.Lint ( lintAnnots )
import GHC.Core.Lint.Interactive ( interactiveInScope )
import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm )
-import GHC.Core.Opt.Simplify.Env( SimplMode(..) )
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Opt.Monad
import GHC.Core.Opt.Pipeline.Types
@@ -153,45 +152,32 @@ getCoreToDo dflags hpt_rule_base extra_vars
maybe_strictness_before _
= CoreDoNothing
- ----------------------------
- base_simpl_mode :: SimplMode
- base_simpl_mode = initSimplMode dflags
-
- -- gentle_mode: make specialiser happy: minimum effort please
- -- See Note [Inline in InitialPhase]
- -- See Note [RULEs enabled in InitialPhase]
- gentle_mode = base_simpl_mode { sm_names = ["Gentle"]
- , sm_phase = InitialPhase
- , sm_case_case = False }
-
- simpl_mode phase name
- = base_simpl_mode { sm_names = [name], sm_phase = phase }
-
- keep_exits :: SimplMode -> SimplMode
- -- See Note [Be selective about not-inlining exit join points]
- -- in GHC.Core.Opt.Exitify
- keep_exits mode = mode { sm_keep_exits = True }
-
- ----------------------------
- run_simplifier mode iter
- = CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter mode hpt_rule_base
-
- simpl_phase phase name iter = CoreDoPasses $
- [ maybe_strictness_before phase
- , run_simplifier (simpl_mode phase name) iter
- , maybe_rule_check phase ]
+ simpl_phase phase name iter
+ = CoreDoPasses
+ $ [ maybe_strictness_before phase
+ , CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter
+ (initSimplMode dflags phase name) hpt_rule_base
+ , maybe_rule_check phase ]
-- Run GHC's internal simplification phase, after all rules have run.
-- See Note [Compiler phases] in GHC.Types.Basic
- simpl_gently = run_simplifier gentle_mode max_iter
- simplify_final name = run_simplifier ( simpl_mode FinalPhase name) max_iter
- simpl_keep_exits name = run_simplifier (keep_exits $ simpl_mode FinalPhase name) max_iter
+ simplify name = simpl_phase FinalPhase name max_iter
+
+ -- initial simplify: mk specialiser happy: minimum effort please
+ -- See Note [Inline in InitialPhase]
+ -- See Note [RULEs enabled in InitialPhase]
+ simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter
+ (initGentleSimplMode dflags) hpt_rule_base
- ----------------------------
dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper]
else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper]
+ demand_analyser = (CoreDoPasses (
+ dmd_cpr_ww ++
+ [simplify "post-worker-wrapper"]
+ ))
+
-- Static forms are moved to the top level with the FloatOut pass.
-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
static_ptrs_float_outwards =
@@ -281,16 +267,14 @@ getCoreToDo dflags hpt_rule_base extra_vars
runWhen call_arity $ CoreDoPasses
[ CoreDoCallArity
- , simplify_final "post-call-arity"
+ , simplify "post-call-arity"
],
-- Strictness analysis
- runWhen strictness $ CoreDoPasses
- (dmd_cpr_ww ++ [simplify_final "post-worker-wrapper"]),
+ runWhen strictness demand_analyser,
runWhen exitification CoreDoExitify,
-- See Note [Placement of the exitification pass]
- -- in GHC.Core.Opt.Exitify
runWhen full_laziness $
CoreDoFloatOutwards FloatOutSwitches {
@@ -312,17 +296,7 @@ getCoreToDo dflags hpt_rule_base extra_vars
runWhen do_float_in CoreDoFloatInwards,
- -- Final tidy-up run of the simplifier
- simpl_keep_exits "final tidy up",
- -- Keep exit join point because this is the first
- -- Simplifier run after Exitify. Subsequent runs will
- -- re-inline those exit join points; their work is done.
- -- See Note [Be selective about not-inlining exit join points]
- -- in GHC.Core.Opt.Exitify
- --
- -- Annoyingly, we only /have/ a subsequent run with -O2. With
- -- plain -O we'll still have those exit join points hanging around.
- -- Oh well.
+ simplify "final", -- Final tidy-up
maybe_rule_check FinalPhase,
@@ -332,31 +306,31 @@ getCoreToDo dflags hpt_rule_base extra_vars
-- Case-liberation for -O2. This should be after
-- strictness analysis and the simplification which follows it.
runWhen liberate_case $ CoreDoPasses
- [ CoreLiberateCase, simplify_final "post-liberate-case" ],
+ [ CoreLiberateCase, simplify "post-liberate-case" ],
-- Run the simplifier after LiberateCase to vastly
-- reduce the possibility of shadowing
-- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr
runWhen spec_constr $ CoreDoPasses
- [ CoreDoSpecConstr, simplify_final "post-spec-constr"],
+ [ CoreDoSpecConstr, simplify "post-spec-constr"],
-- See Note [Simplify after SpecConstr]
maybe_rule_check FinalPhase,
runWhen late_specialise $ CoreDoPasses
- [ CoreDoSpecialising, simplify_final "post-late-spec"],
+ [ CoreDoSpecialising, simplify "post-late-spec"],
-- LiberateCase can yield new CSE opportunities because it peels
-- off one layer of a recursive function (concretely, I saw this
-- in wheel-sieve1), and I'm guessing that SpecConstr can too
-- And CSE is a very cheap pass. So it seems worth doing here.
runWhen ((liberate_case || spec_constr) && cse) $ CoreDoPasses
- [ CoreCSE, simplify_final "post-final-cse" ],
+ [ CoreCSE, simplify "post-final-cse" ],
--------- End of -O2 passes --------------
runWhen late_dmd_anal $ CoreDoPasses (
- dmd_cpr_ww ++ [simplify_final "post-late-ww"]
+ dmd_cpr_ww ++ [simplify "post-late-ww"]
),
-- Final run of the demand_analyser, ensures that one-shot thunks are
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -248,16 +248,13 @@ data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad
, sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options
, sm_case_case :: !Bool -- ^ Whether case-of-case is enabled
, sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled
- , sm_keep_exits :: !Bool -- ^ True <=> keep ExitJoinIds
- -- See Note [Do not inline exit join points]
- -- in GHC.Core.Opt.Exitify
- , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out
+ , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out
, sm_do_eta_reduction :: !Bool
- , sm_arity_opts :: !ArityOpts
- , sm_rule_opts :: !RuleOpts
- , sm_case_folding :: !Bool
- , sm_case_merge :: !Bool
- , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
+ , sm_arity_opts :: !ArityOpts
+ , sm_rule_opts :: !RuleOpts
+ , sm_case_folding :: !Bool
+ , sm_case_merge :: !Bool
+ , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
}
instance Outputable SimplMode where
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1395,11 +1395,11 @@ preInlineUnconditionally
-- Reason: we don't want to inline single uses, or discard dead bindings,
-- for unlifted, side-effect-ful bindings
preInlineUnconditionally env top_lvl bndr rhs rhs_env
- | not pre_inline = Nothing
+ | not pre_inline_unconditionally = Nothing
| not active = Nothing
| isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids]
| isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally]
- | keep_exits, isExitJoinId bndr = Nothing -- Note [Do not inline exit join points]
+ | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points]
-- in module Exitify
| not (one_occ (idOccInfo bndr)) = Nothing
| not (isStableUnfolding unf) = Just $! (extend_subst_with rhs)
@@ -1409,36 +1409,19 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
, Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl)
| otherwise = Nothing
where
- mode = seMode env
- phase = sm_phase mode
- keep_exits = sm_keep_exits mode
- pre_inline = sm_pre_inline mode
-
unf = idUnfolding bndr
extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
one_occ IAmDead = True -- Happens in ((\x.1) v)
-
one_occ OneOcc{ occ_n_br = 1
, occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase
-
one_occ OneOcc{ occ_n_br = 1
, occ_in_lam = IsInsideLam
, occ_int_cxt = IsInteresting } = canInlineInLam rhs
+ one_occ _ = False
- one_occ OneOcc{ occ_n_br = 1 } -- Inline join point that are used once, even inside
- | isJoinId bndr = True -- lambdas (which are presumably other join points)
- -- E.g. join j x = rhs in
- -- joinrec k y = ....j x....
- -- Here j must be an exit for k, and we can safely inline it under the lambda
- -- This includes the case where j is nullary: a nullary join point is just the
- -- same as an arity-1 one. So we don't look at occ_int_cxt.
- -- All of this only applies if keep_exits is False, otherwise the
- -- earlier guard on preInlineUnconditionally would have fired
-
- one_occ _ = False
-
- active = isActive phase (inlinePragmaActivation inline_prag)
+ pre_inline_unconditionally = sePreInline env
+ active = isActive (sePhase env) (inlinePragmaActivation inline_prag)
-- See Note [pre/postInlineUnconditionally in gentle mode]
inline_prag = idInlinePragma bndr
@@ -1470,7 +1453,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
-- not ticks. Counting ticks cannot be duplicated, and non-counting
-- ticks around a Lam will disappear anyway.
- early_phase = phase /= FinalPhase
+ early_phase = sePhase env /= FinalPhase
-- If we don't have this early_phase test, consider
-- x = length [1,2,3]
-- The full laziness pass carefully floats all the cons cells to
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -1532,10 +1532,8 @@ scExpr' env (Case scrut b ty alts)
scrut_occ = case con of
DataAlt dc -- See Note [Do not specialise evals]
| not (single_alt && all deadArgOcc arg_occs)
- -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $
- ScrutOcc (unitUFM dc arg_occs)
- _ -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $
- UnkOcc
+ -> ScrutOcc (unitUFM dc arg_occs)
+ _ -> UnkOcc
; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }
=====================================
compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
=====================================
@@ -2,6 +2,7 @@ module GHC.Driver.Config.Core.Opt.Simplify
( initSimplifyExprOpts
, initSimplifyOpts
, initSimplMode
+ , initGentleSimplMode
) where
import GHC.Prelude
@@ -26,13 +27,12 @@ import GHC.Types.Var ( Var )
initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts
initSimplifyExprOpts dflags ic = SimplifyExprOpts
{ se_fam_inst = snd $ ic_instances ic
-
- , se_mode = (initSimplMode dflags) { sm_names = ["GHCi"]
- , sm_inline = False }
- -- sm_inline: do not do any inlining, in case we expose
- -- some unboxed tuple stuff that confuses the bytecode
+ , se_mode = (initSimplMode dflags InitialPhase "GHCi")
+ { sm_inline = False
+ -- Do not do any inlining, in case we expose some
+ -- unboxed tuple stuff that confuses the bytecode
-- interpreter
-
+ }
, se_top_env_cfg = TopEnvConfig
{ te_history_size = historySize dflags
, te_tick_factor = simplTickFactor dflags
@@ -56,25 +56,31 @@ initSimplifyOpts dflags extra_vars iterations mode hpt_rule_base = let
}
in opts
-initSimplMode :: DynFlags -> SimplMode
-initSimplMode dflags = SimplMode
- { sm_names = ["Unknown simplifier run"] -- Always overriden
- , sm_phase = InitialPhase
- , sm_rules = gopt Opt_EnableRewriteRules dflags
- , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags
- , sm_pre_inline = gopt Opt_SimplPreInlining dflags
- , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags
- , sm_uf_opts = unfoldingOpts dflags
- , sm_float_enable = floatEnable dflags
- , sm_arity_opts = initArityOpts dflags
- , sm_rule_opts = initRuleOpts dflags
- , sm_case_folding = gopt Opt_CaseFolding dflags
- , sm_case_merge = gopt Opt_CaseMerge dflags
- , sm_co_opt_opts = initOptCoercionOpts dflags
+initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode
+initSimplMode dflags phase name = SimplMode
+ { sm_names = [name]
+ , sm_phase = phase
+ , sm_rules = gopt Opt_EnableRewriteRules dflags
+ , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags
, sm_cast_swizzle = True
- , sm_inline = True
- , sm_case_case = True
- , sm_keep_exits = False
+ , sm_inline = True
+ , sm_uf_opts = unfoldingOpts dflags
+ , sm_case_case = True
+ , sm_pre_inline = gopt Opt_SimplPreInlining dflags
+ , sm_float_enable = floatEnable dflags
+ , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags
+ , sm_arity_opts = initArityOpts dflags
+ , sm_rule_opts = initRuleOpts dflags
+ , sm_case_folding = gopt Opt_CaseFolding dflags
+ , sm_case_merge = gopt Opt_CaseMerge dflags
+ , sm_co_opt_opts = initOptCoercionOpts dflags
+ }
+
+initGentleSimplMode :: DynFlags -> SimplMode
+initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")
+ { -- Don't do case-of-case transformations.
+ -- This makes full laziness work better
+ sm_case_case = False
}
floatEnable :: DynFlags -> FloatEnable
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -3700,11 +3700,13 @@ allocatePriorComments ss comment_q mheader_comments =
cmp (L l _) = anchor l <= ss
(newAnns,after) = partition cmp comment_q
comment_q'= after
- (prior_comments, decl_comments) = splitPriorComments ss newAnns
+ (prior_comments, decl_comments)
+ = case mheader_comments of
+ Strict.Nothing -> (reverse newAnns, [])
+ _ -> splitPriorComments ss newAnns
in
case mheader_comments of
Strict.Nothing -> (Strict.Just prior_comments, comment_q', decl_comments)
- -- Strict.Nothing -> (Strict.Just [], comment_q', newAnns)
Strict.Just _ -> (mheader_comments, comment_q', reverse newAnns)
allocateFinalComments
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -893,17 +893,15 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
-- Rename the pragmas and signatures
-- Annoyingly the type variables /are/ in scope for signatures, but
- -- /are not/ in scope in the SPECIALISE instance pramas; e.g.
- -- instance Eq a => Eq (T a) where
- -- (==) :: a -> a -> a
- -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
- ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs
+ -- /are not/ in scope in SPECIALISE and SPECIALISE instance pragmas.
+ -- See Note [Type variable scoping in SPECIALISE pragmas].
+ ; let (spec_prags, other_sigs) = partition (isSpecLSig <||> isSpecInstLSig) sigs
bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds')
sig_ctxt | is_cls_decl = ClsDeclCtxt cls
| otherwise = InstDeclCtxt bound_nms
- ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags
- ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $
- renameSigs sig_ctxt other_sigs
+ ; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags
+ ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $
+ renameSigs sig_ctxt other_sigs
-- Rename the bindings RHSs. Again there's an issue about whether the
-- type variables from the class/instance head are in scope.
@@ -914,8 +912,47 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
emptyFVs binds_w_dus
; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
- ; return ( binds'', spec_inst_prags' ++ other_sigs'
- , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }
+ ; return ( binds'', spec_prags' ++ other_sigs'
+ , sig_fvs `plusFV` spg_fvs `plusFV` bind_fvs) }
+
+{- Note [Type variable scoping in SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When renaming the methods of a class or instance declaration, we must be careful
+with the scoping of the type variables that occur in SPECIALISE and SPECIALISE instance
+pragmas: the type variables from the class/instance header DO NOT scope over these,
+unlike class/instance method type signatures.
+
+Examples:
+
+ 1. SPECIALISE
+
+ class C a where
+ meth :: a
+ instance C (Maybe a) where
+ meth = Nothing
+ {-# SPECIALISE INLINE meth :: Maybe [a] #-}
+
+ 2. SPECIALISE instance
+
+ instance Eq a => Eq (T a) where
+ (==) :: a -> a -> a
+ {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
+
+ In both cases, the type variable `a` mentioned in the PRAGMA is NOT the same
+ as the type variable `a` from the instance header.
+ For example, the SPECIALISE instance pragma above is a shorthand for
+
+ {-# SPECIALISE instance forall a. Eq a => Eq (T [a]) #-}
+
+ which is alpha-equivalent to
+
+ {-# SPECIALISE instance forall b. Eq b => Eq (T [b]) #-}
+
+ This shows that the type variables are not bound in the header.
+
+ Getting this scoping wrong can lead to out-of-scope type variable errors from
+ Core Lint, see e.g. #22913.
+-}
rnMethodBindLHS :: Bool -> Name
-> LHsBindLR GhcPs GhcPs
=====================================
testsuite/driver/runtests.py
=====================================
@@ -26,7 +26,9 @@ from pathlib import Path
# So we import it here first, so that the testsuite doesn't appear to fail.
import subprocess
-from testutil import getStdout, Watcher, str_warn, str_info, print_table, shorten_metric_name
+from concurrent.futures import ThreadPoolExecutor
+
+from testutil import getStdout, str_warn, str_info, print_table, shorten_metric_name
from testglobals import getConfig, ghc_env, getTestRun, TestConfig, \
TestOptions, brokens, PerfMetric
from my_typing import TestName
@@ -151,7 +153,6 @@ config.broken_tests |= {TestName(t) for t in args.broken_test}
if args.threads:
config.threads = args.threads
- config.use_threads = True
if args.verbose is not None:
config.verbose = args.verbose
@@ -481,26 +482,28 @@ if config.list_broken:
print('WARNING:', len(t.framework_failures), 'framework failures!')
print('')
else:
- # completion watcher
- watcher = Watcher(len(parallelTests))
-
# Now run all the tests
try:
- for oneTest in parallelTests:
- if stopping():
- break
- oneTest(watcher)
+ with ThreadPoolExecutor(max_workers=config.threads) as executor:
+ for oneTest in parallelTests:
+ if stopping():
+ break
+ oneTest(executor)
- # wait for parallel tests to finish
- if not stopping():
- watcher.wait()
+ # wait for parallel tests to finish
+ if not stopping():
+ executor.shutdown(wait=True)
# Run the following tests purely sequential
- config.use_threads = False
- for oneTest in aloneTests:
- if stopping():
- break
- oneTest(watcher)
+ with ThreadPoolExecutor(max_workers=1) as executor:
+ for oneTest in aloneTests:
+ if stopping():
+ break
+ oneTest(executor)
+
+ if not stopping():
+ executor.shutdown(wait=True)
+
except KeyboardInterrupt:
pass
=====================================
testsuite/driver/testglobals.py
=====================================
@@ -177,7 +177,6 @@ class TestConfig:
# threads
self.threads = 1
- self.use_threads = False
# tests which should be considered to be broken during this testsuite
# run.
=====================================
testsuite/driver/testlib.py
=====================================
@@ -36,10 +36,7 @@ from my_typing import *
from threading import Timer
from collections import OrderedDict
-global pool_sema
-if config.use_threads:
- import threading
- pool_sema = threading.BoundedSemaphore(value=config.threads)
+import threading
global wantToStop
wantToStop = False
@@ -84,12 +81,7 @@ def get_all_ways() -> Set[WayName]:
# testdir_testopts after each test).
global testopts_local
-if config.use_threads:
- testopts_local = threading.local()
-else:
- class TestOpts_Local:
- pass
- testopts_local = TestOpts_Local() # type: ignore
+testopts_local = threading.local()
def getTestOpts() -> TestOptions:
return testopts_local.x
@@ -1020,16 +1012,8 @@ parallelTests = []
aloneTests = []
allTestNames = set([]) # type: Set[TestName]
-def runTest(watcher, opts, name: TestName, func, args):
- if config.use_threads:
- pool_sema.acquire()
- t = threading.Thread(target=test_common_thread,
- name=name,
- args=(watcher, name, opts, func, args))
- t.daemon = False
- t.start()
- else:
- test_common_work(watcher, name, opts, func, args)
+def runTest(executor, opts, name: TestName, func, args):
+ return executor.submit(test_common_work, name, opts, func, args)
# name :: String
# setup :: [TestOpt] -> IO ()
@@ -1067,20 +1051,13 @@ def test(name: TestName,
if name in config.broken_tests:
myTestOpts.expect = 'fail'
- thisTest = lambda watcher: runTest(watcher, myTestOpts, name, func, args)
+ thisTest = lambda executor: runTest(executor, myTestOpts, name, func, args)
if myTestOpts.alone:
aloneTests.append(thisTest)
else:
parallelTests.append(thisTest)
allTestNames.add(name)
-if config.use_threads:
- def test_common_thread(watcher, name, opts, func, args):
- try:
- test_common_work(watcher, name, opts, func, args)
- finally:
- pool_sema.release()
-
def get_package_cache_timestamp() -> float:
if config.package_conf_cache_file is None:
return 0.0
@@ -1094,8 +1071,7 @@ do_not_copy = ('.hi', '.o', '.dyn_hi'
, '.dyn_o', '.out'
,'.hi-boot', '.o-boot') # 12112
-def test_common_work(watcher: testutil.Watcher,
- name: TestName, opts,
+def test_common_work(name: TestName, opts,
func, args) -> None:
try:
t.total_tests += 1
@@ -1214,8 +1190,6 @@ def test_common_work(watcher: testutil.Watcher,
except Exception as e:
framework_fail(name, None, 'Unhandled exception: ' + str(e))
- finally:
- watcher.notify()
def do_test(name: TestName,
way: WayName,
=====================================
testsuite/driver/testutil.py
=====================================
@@ -5,8 +5,6 @@ import tempfile
from pathlib import Path, PurePath
from term_color import Color, colored
-import threading
-
from my_typing import *
@@ -125,24 +123,6 @@ else:
else:
os.symlink(str(src), str(dst))
-class Watcher(object):
- def __init__(self, count: int) -> None:
- self.pool = count
- self.evt = threading.Event()
- self.sync_lock = threading.Lock()
- if count <= 0:
- self.evt.set()
-
- def wait(self):
- self.evt.wait()
-
- def notify(self):
- self.sync_lock.acquire()
- self.pool -= 1
- if self.pool <= 0:
- self.evt.set()
- self.sync_lock.release()
-
def memoize(f):
"""
A decorator to memoize a nullary function.
=====================================
testsuite/tests/ghc-api/exactprint/T22919.hs
=====================================
@@ -0,0 +1,2 @@
+module T22919 {- comment -} where
+foo = 's'
=====================================
testsuite/tests/ghc-api/exactprint/T22919.stderr
=====================================
@@ -0,0 +1,116 @@
+
+==================== Parser AST ====================
+
+(L
+ { T22919.hs:1:1 }
+ (HsModule
+ (XModulePs
+ (EpAnn
+ (Anchor
+ { T22919.hs:1:1 }
+ (UnchangedAnchor))
+ (AnnsModule
+ [(AddEpAnn AnnModule (EpaSpan { T22919.hs:1:1-6 }))
+ ,(AddEpAnn AnnWhere (EpaSpan { T22919.hs:1:29-33 }))]
+ (AnnList
+ (Nothing)
+ (Nothing)
+ (Nothing)
+ []
+ [])
+ (Just
+ ((,)
+ { T22919.hs:3:1 }
+ { T22919.hs:2:7-9 })))
+ (EpaCommentsBalanced
+ [(L
+ (Anchor
+ { T22919.hs:1:15-27 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaBlockComment
+ "{- comment -}")
+ { T22919.hs:1:8-13 }))]
+ []))
+ (VirtualBraces
+ (1))
+ (Nothing)
+ (Nothing))
+ (Just
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { T22919.hs:1:8-13 })
+ {ModuleName: T22919}))
+ (Nothing)
+ []
+ [(L
+ (SrcSpanAnn (EpAnn
+ (Anchor
+ { T22919.hs:2:1-9 }
+ (UnchangedAnchor))
+ (AnnListItem
+ [])
+ (EpaComments
+ [])) { T22919.hs:2:1-9 })
+ (ValD
+ (NoExtField)
+ (FunBind
+ (NoExtField)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { T22919.hs:2:1-3 })
+ (Unqual
+ {OccName: foo}))
+ (MG
+ (FromSource)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { T22919.hs:2:1-9 })
+ [(L
+ (SrcSpanAnn (EpAnnNotUsed) { T22919.hs:2:1-9 })
+ (Match
+ (EpAnn
+ (Anchor
+ { T22919.hs:2:1-9 }
+ (UnchangedAnchor))
+ []
+ (EpaComments
+ []))
+ (FunRhs
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { T22919.hs:2:1-3 })
+ (Unqual
+ {OccName: foo}))
+ (Prefix)
+ (NoSrcStrict))
+ []
+ (GRHSs
+ (EpaComments
+ [])
+ [(L
+ (SrcSpanAnn
+ (EpAnnNotUsed)
+ { T22919.hs:2:5-9 })
+ (GRHS
+ (EpAnn
+ (Anchor
+ { T22919.hs:2:5-9 }
+ (UnchangedAnchor))
+ (GrhsAnn
+ (Nothing)
+ (AddEpAnn AnnEqual (EpaSpan { T22919.hs:2:5 })))
+ (EpaComments
+ []))
+ []
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { T22919.hs:2:7-9 })
+ (HsLit
+ (EpAnn
+ (Anchor
+ { T22919.hs:2:7-9 }
+ (UnchangedAnchor))
+ (NoEpAnns)
+ (EpaComments
+ []))
+ (HsChar
+ (SourceText 's')
+ ('s'))))))]
+ (EmptyLocalBinds
+ (NoExtField)))))])))))]))
=====================================
testsuite/tests/ghc-api/exactprint/Test20239.stderr
=====================================
@@ -23,7 +23,14 @@
{ Test20239.hs:8:1 }
{ Test20239.hs:7:34-63 })))
(EpaCommentsBalanced
- []
+ [(L
+ (Anchor
+ { Test20239.hs:3:1-28 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- | Leading Haddock Comment")
+ { Test20239.hs:1:18-22 }))]
[(L
(Anchor
{ Test20239.hs:7:34-63 }
@@ -50,14 +57,7 @@
(AnnListItem
[])
(EpaComments
- [(L
- (Anchor
- { Test20239.hs:3:1-28 }
- (UnchangedAnchor))
- (EpaComment
- (EpaLineComment
- "-- | Leading Haddock Comment")
- { Test20239.hs:1:18-22 }))])) { Test20239.hs:(4,1)-(6,86) })
+ [])) { Test20239.hs:(4,1)-(6,86) })
(InstD
(NoExtField)
(DataFamInstD
@@ -323,5 +323,5 @@
-Test20239.hs:4:15: error: [GHC-76037]
+Test20239.hs:4:15: [GHC-76037]
Not in scope: type constructor or class ‘Method’
=====================================
testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr
=====================================
@@ -30,7 +30,15 @@
(EpaComment
(EpaLineComment
"-- leading comments")
- { ZeroWidthSemi.hs:1:22-26 }))]
+ { ZeroWidthSemi.hs:1:22-26 }))
+ ,(L
+ (Anchor
+ { ZeroWidthSemi.hs:5:1-19 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- Function comment")
+ { ZeroWidthSemi.hs:3:1-19 }))]
[(L
(Anchor
{ ZeroWidthSemi.hs:8:1-58 }
@@ -57,14 +65,7 @@
(AnnListItem
[])
(EpaComments
- [(L
- (Anchor
- { ZeroWidthSemi.hs:5:1-19 }
- (UnchangedAnchor))
- (EpaComment
- (EpaLineComment
- "-- Function comment")
- { ZeroWidthSemi.hs:3:1-19 }))])) { ZeroWidthSemi.hs:6:1-5 })
+ [])) { ZeroWidthSemi.hs:6:1-5 })
(ValD
(NoExtField)
(FunBind
=====================================
testsuite/tests/ghc-api/exactprint/all.T
=====================================
@@ -38,3 +38,4 @@ test('AddHiding1', ignore_stderr, makefile_test, ['AddHiding1'])
test('AddHiding2', ignore_stderr, makefile_test, ['AddHiding2'])
test('Test20239', normal, compile_fail, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
test('ZeroWidthSemi', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
+test('T22919', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
=====================================
testsuite/tests/parser/should_compile/DumpParsedAstComments.hs
=====================================
@@ -4,6 +4,9 @@
-}
module DumpParsedAstComments where
+-- comment 1 for bar
+-- comment 2 for bar
+bar = 1
-- Other comment
-- comment 1 for foo
=====================================
testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
=====================================
@@ -21,8 +21,8 @@
[])
(Just
((,)
- { DumpParsedAstComments.hs:17:1 }
- { DumpParsedAstComments.hs:16:17-23 })))
+ { DumpParsedAstComments.hs:20:1 }
+ { DumpParsedAstComments.hs:19:17-23 })))
(EpaCommentsBalanced
[(L
(Anchor
@@ -42,12 +42,20 @@
{ DumpParsedAstComments.hs:1:1-28 }))
,(L
(Anchor
- { DumpParsedAstComments.hs:7:1-16 }
+ { DumpParsedAstComments.hs:7:1-20 }
(UnchangedAnchor))
(EpaComment
(EpaLineComment
- "-- Other comment")
- { DumpParsedAstComments.hs:5:30-34 }))]
+ "-- comment 1 for bar")
+ { DumpParsedAstComments.hs:5:30-34 }))
+ ,(L
+ (Anchor
+ { DumpParsedAstComments.hs:8:1-20 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- comment 2 for bar")
+ { DumpParsedAstComments.hs:7:1-20 }))]
[]))
(VirtualBraces
(1))
@@ -62,55 +70,139 @@
[(L
(SrcSpanAnn (EpAnn
(Anchor
- { DumpParsedAstComments.hs:(11,1)-(13,3) }
+ { DumpParsedAstComments.hs:9:1-7 }
+ (UnchangedAnchor))
+ (AnnListItem
+ [])
+ (EpaComments
+ [])) { DumpParsedAstComments.hs:9:1-7 })
+ (ValD
+ (NoExtField)
+ (FunBind
+ (NoExtField)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:9:1-3 })
+ (Unqual
+ {OccName: bar}))
+ (MG
+ (FromSource)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:9:1-7 })
+ [(L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:9:1-7 })
+ (Match
+ (EpAnn
+ (Anchor
+ { DumpParsedAstComments.hs:9:1-7 }
+ (UnchangedAnchor))
+ []
+ (EpaComments
+ []))
+ (FunRhs
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:9:1-3 })
+ (Unqual
+ {OccName: bar}))
+ (Prefix)
+ (NoSrcStrict))
+ []
+ (GRHSs
+ (EpaComments
+ [])
+ [(L
+ (SrcSpanAnn
+ (EpAnnNotUsed)
+ { DumpParsedAstComments.hs:9:5-7 })
+ (GRHS
+ (EpAnn
+ (Anchor
+ { DumpParsedAstComments.hs:9:5-7 }
+ (UnchangedAnchor))
+ (GrhsAnn
+ (Nothing)
+ (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:9:5 })))
+ (EpaComments
+ []))
+ []
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:9:7 })
+ (HsOverLit
+ (EpAnn
+ (Anchor
+ { DumpParsedAstComments.hs:9:7 }
+ (UnchangedAnchor))
+ (NoEpAnns)
+ (EpaComments
+ []))
+ (OverLit
+ (NoExtField)
+ (HsIntegral
+ (IL
+ (SourceText 1)
+ (False)
+ (1))))))))]
+ (EmptyLocalBinds
+ (NoExtField)))))])))))
+ ,(L
+ (SrcSpanAnn (EpAnn
+ (Anchor
+ { DumpParsedAstComments.hs:(14,1)-(16,3) }
(UnchangedAnchor))
(AnnListItem
[])
(EpaComments
[(L
(Anchor
- { DumpParsedAstComments.hs:9:1-20 }
+ { DumpParsedAstComments.hs:10:1-16 }
+ (UnchangedAnchor))
+ (EpaComment
+ (EpaLineComment
+ "-- Other comment")
+ { DumpParsedAstComments.hs:9:7 }))
+ ,(L
+ (Anchor
+ { DumpParsedAstComments.hs:12:1-20 }
(UnchangedAnchor))
(EpaComment
(EpaLineComment
"-- comment 1 for foo")
- { DumpParsedAstComments.hs:7:1-16 }))
+ { DumpParsedAstComments.hs:10:1-16 }))
,(L
(Anchor
- { DumpParsedAstComments.hs:10:1-20 }
+ { DumpParsedAstComments.hs:13:1-20 }
(UnchangedAnchor))
(EpaComment
(EpaLineComment
"-- comment 2 for foo")
- { DumpParsedAstComments.hs:9:1-20
- }))])) { DumpParsedAstComments.hs:(11,1)-(13,3) })
+ { DumpParsedAstComments.hs:12:1-20
+ }))])) { DumpParsedAstComments.hs:(14,1)-(16,3) })
(ValD
(NoExtField)
(FunBind
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:11:1-3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:14:1-3 })
(Unqual
{OccName: foo}))
(MG
(FromSource)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,1)-(13,3)
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(14,1)-(16,3)
})
[(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,1)-(13,3)
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(14,1)-(16,3)
})
(Match
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:(11,1)-(13,3) }
+ { DumpParsedAstComments.hs:(14,1)-(16,3) }
(UnchangedAnchor))
[]
(EpaComments
[]))
(FunRhs
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:11:1-3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:14:1-3 })
(Unqual
{OccName: foo}))
(Prefix)
@@ -122,72 +214,72 @@
[(L
(SrcSpanAnn
(EpAnnNotUsed)
- { DumpParsedAstComments.hs:(11,5)-(13,3) })
+ { DumpParsedAstComments.hs:(14,5)-(16,3) })
(GRHS
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:(11,5)-(13,3) }
+ { DumpParsedAstComments.hs:(14,5)-(16,3) }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
- (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:11:5 })))
+ (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:14:5 })))
(EpaComments
[]))
[]
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,7)-(13,3)
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(14,7)-(16,3)
})
(HsDo
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:(11,7)-(13,3) }
+ { DumpParsedAstComments.hs:(14,7)-(16,3) }
(UnchangedAnchor))
(AnnList
(Just
(Anchor
- { DumpParsedAstComments.hs:13:3 }
+ { DumpParsedAstComments.hs:16:3 }
(UnchangedAnchor)))
(Nothing)
(Nothing)
- [(AddEpAnn AnnDo (EpaSpan { DumpParsedAstComments.hs:11:7-8 }))]
+ [(AddEpAnn AnnDo (EpaSpan { DumpParsedAstComments.hs:14:7-8 }))]
[])
(EpaComments
[(L
(Anchor
- { DumpParsedAstComments.hs:12:3-19 }
+ { DumpParsedAstComments.hs:15:3-19 }
(UnchangedAnchor))
(EpaComment
(EpaLineComment
"-- normal comment")
- { DumpParsedAstComments.hs:11:7-8 }))]))
+ { DumpParsedAstComments.hs:14:7-8 }))]))
(DoExpr
(Nothing))
(L
(SrcSpanAnn (EpAnn
(Anchor
- { DumpParsedAstComments.hs:13:3 }
+ { DumpParsedAstComments.hs:16:3 }
(UnchangedAnchor))
(AnnList
(Just
(Anchor
- { DumpParsedAstComments.hs:13:3 }
+ { DumpParsedAstComments.hs:16:3 }
(UnchangedAnchor)))
(Nothing)
(Nothing)
[]
[])
(EpaComments
- [])) { DumpParsedAstComments.hs:13:3 })
+ [])) { DumpParsedAstComments.hs:16:3 })
[(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:13:3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:3 })
(BodyStmt
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:13:3 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:3 })
(HsOverLit
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:13:3 }
+ { DumpParsedAstComments.hs:16:3 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
@@ -206,45 +298,45 @@
,(L
(SrcSpanAnn (EpAnn
(Anchor
- { DumpParsedAstComments.hs:16:1-23 }
+ { DumpParsedAstComments.hs:19:1-23 }
(UnchangedAnchor))
(AnnListItem
[])
(EpaComments
[(L
(Anchor
- { DumpParsedAstComments.hs:15:1-20 }
+ { DumpParsedAstComments.hs:18:1-20 }
(UnchangedAnchor))
(EpaComment
(EpaLineComment
"-- | Haddock comment")
- { DumpParsedAstComments.hs:13:3
- }))])) { DumpParsedAstComments.hs:16:1-23 })
+ { DumpParsedAstComments.hs:16:3
+ }))])) { DumpParsedAstComments.hs:19:1-23 })
(ValD
(NoExtField)
(FunBind
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-4 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:19:1-4 })
(Unqual
{OccName: main}))
(MG
(FromSource)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:19:1-23 })
[(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:19:1-23 })
(Match
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:16:1-23 }
+ { DumpParsedAstComments.hs:19:1-23 }
(UnchangedAnchor))
[]
(EpaComments
[]))
(FunRhs
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-4 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:19:1-4 })
(Unqual
{OccName: main}))
(Prefix)
@@ -256,42 +348,42 @@
[(L
(SrcSpanAnn
(EpAnnNotUsed)
- { DumpParsedAstComments.hs:16:6-23 })
+ { DumpParsedAstComments.hs:19:6-23 })
(GRHS
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:16:6-23 }
+ { DumpParsedAstComments.hs:19:6-23 }
(UnchangedAnchor))
(GrhsAnn
(Nothing)
- (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:16:6 })))
+ (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:19:6 })))
(EpaComments
[]))
[]
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:19:8-23 })
(HsApp
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:16:8-23 }
+ { DumpParsedAstComments.hs:19:8-23 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
[]))
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-15 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:19:8-15 })
(HsVar
(NoExtField)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-15 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:19:8-15 })
(Unqual
{OccName: putStrLn}))))
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:17-23 })
+ (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:19:17-23 })
(HsLit
(EpAnn
(Anchor
- { DumpParsedAstComments.hs:16:17-23 }
+ { DumpParsedAstComments.hs:19:17-23 }
(UnchangedAnchor))
(NoEpAnns)
(EpaComments
=====================================
testsuite/tests/rename/should_compile/T22913.hs
=====================================
@@ -0,0 +1,10 @@
+module T22913 where
+
+class FromSourceIO a where
+ fromSourceIO :: a
+instance FromSourceIO (Maybe o) where
+ fromSourceIO = undefined
+ {-# SPECIALISE INLINE fromSourceIO :: Maybe o #-}
+ -- This SPECIALISE pragma caused a Core Lint error
+ -- due to incorrectly scoping the type variable 'o' from the instance header
+ -- over the SPECIALISE pragma.
=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -199,3 +199,4 @@ test('T22513f', normal, compile, ['-Wterm-variable-capture'])
test('T22513g', normal, compile, ['-Wterm-variable-capture'])
test('T22513h', normal, compile, ['-Wterm-variable-capture'])
test('T22513i', req_th, compile, ['-Wterm-variable-capture'])
+test('T22913', normal, compile, [''])
=====================================
testsuite/tests/simplCore/should_compile/T21148.hs deleted
=====================================
@@ -1,12 +0,0 @@
-module T211148 where
-
--- The point of this test is that f should get a (nested)
--- CPR property, with a worker of type
--- $wf :: Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
-
-{-# NOINLINE f #-}
--- The NOINLINE makes GHC do a worker/wrapper split
--- even though f is small
-f :: Int -> IO Int
-f x = return $! sum [0..x]
-
=====================================
testsuite/tests/simplCore/should_compile/T21148.stderr deleted
=====================================
@@ -1,126 +0,0 @@
-
-==================== Tidy Core ====================
-Result size of Tidy Core
- = {terms: 73, types: 80, coercions: 6, joins: 2/2}
-
--- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T211148.$trModule4 :: GHC.Prim.Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
-T211148.$trModule4 = "main"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T211148.$trModule3 :: GHC.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-T211148.$trModule3 = GHC.Types.TrNameS T211148.$trModule4
-
--- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
-T211148.$trModule2 :: GHC.Prim.Addr#
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
-T211148.$trModule2 = "T211148"#
-
--- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-T211148.$trModule1 :: GHC.Types.TrName
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-T211148.$trModule1 = GHC.Types.TrNameS T211148.$trModule2
-
--- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
-T211148.$trModule :: GHC.Types.Module
-[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
-T211148.$trModule
- = GHC.Types.Module T211148.$trModule3 T211148.$trModule1
-
--- RHS size: {terms: 41, types: 35, coercions: 0, joins: 2/2}
-T211148.$wf [InlPrag=NOINLINE]
- :: GHC.Prim.Int#
- -> GHC.Prim.State# GHC.Prim.RealWorld
- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
-[GblId, Arity=2, Str=<L><L>, Unf=OtherCon []]
-T211148.$wf
- = \ (ww_s179 :: GHC.Prim.Int#)
- (eta_s17b [OS=OneShot] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
- case GHC.Prim.># 0# ww_s179 of {
- __DEFAULT ->
- join {
- exit_X0 [Dmd=SC(S,C(1,!P(L,L)))]
- :: GHC.Prim.Int#
- -> GHC.Prim.Int#
- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
- [LclId[JoinId(2)(Nothing)], Arity=2, Str=<L><L>]
- exit_X0 (x_s16Z [OS=OneShot] :: GHC.Prim.Int#)
- (ww1_s172 [OS=OneShot] :: GHC.Prim.Int#)
- = (# eta_s17b, GHC.Prim.+# ww1_s172 x_s16Z #) } in
- joinrec {
- $wgo3_s175 [InlPrag=[2], Occ=LoopBreaker, Dmd=SC(S,C(1,!P(L,L)))]
- :: GHC.Prim.Int#
- -> GHC.Prim.Int#
- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
- [LclId[JoinId(2)(Nothing)], Arity=2, Str=<L><L>, Unf=OtherCon []]
- $wgo3_s175 (x_s16Z :: GHC.Prim.Int#) (ww1_s172 :: GHC.Prim.Int#)
- = case GHC.Prim.==# x_s16Z ww_s179 of {
- __DEFAULT ->
- jump $wgo3_s175
- (GHC.Prim.+# x_s16Z 1#) (GHC.Prim.+# ww1_s172 x_s16Z);
- 1# -> jump exit_X0 x_s16Z ww1_s172
- }; } in
- jump $wgo3_s175 0# 0#;
- 1# -> (# eta_s17b, 0# #)
- }
-
--- RHS size: {terms: 14, types: 19, coercions: 0, joins: 0/0}
-T211148.f1 [InlPrag=NOINLINE[final]]
- :: Int
- -> GHC.Prim.State# GHC.Prim.RealWorld
- -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)
-[GblId,
- Arity=2,
- Str=<1!P(L)><L>,
- Cpr=1(, 1),
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
- Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
- Tmpl= \ (x_s177 [Occ=Once1!] :: Int)
- (eta_s17b [Occ=Once1, OS=OneShot]
- :: GHC.Prim.State# GHC.Prim.RealWorld) ->
- case x_s177 of { GHC.Types.I# ww_s179 [Occ=Once1] ->
- case T211148.$wf ww_s179 eta_s17b of
- { (# ww1_s17e [Occ=Once1], ww2_s17j [Occ=Once1] #) ->
- (# ww1_s17e, GHC.Types.I# ww2_s17j #)
- }
- }}]
-T211148.f1
- = \ (x_s177 :: Int)
- (eta_s17b [OS=OneShot] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
- case x_s177 of { GHC.Types.I# ww_s179 ->
- case T211148.$wf ww_s179 eta_s17b of { (# ww1_s17e, ww2_s17j #) ->
- (# ww1_s17e, GHC.Types.I# ww2_s17j #)
- }
- }
-
--- RHS size: {terms: 1, types: 0, coercions: 6, joins: 0/0}
-f [InlPrag=NOINLINE[final]] :: Int -> IO Int
-[GblId,
- Arity=2,
- Str=<1!P(L)><L>,
- Cpr=1(, 1),
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
- Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
-f = T211148.f1
- `cast` (<Int>_R %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] <Int>_R)
- :: (Int
- -> GHC.Prim.State# GHC.Prim.RealWorld
- -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #))
- ~R# (Int -> IO Int))
-
-
-
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -429,7 +429,6 @@ test('T21763a', only_ways(['optasm']), compile, ['-O2 -ddump-rules'])
test('T22028', normal, compile, ['-O -ddump-rule-firings'])
test('T22114', normal, compile, ['-O'])
test('T21286', normal, multimod_compile, ['T21286', '-O -ddump-rule-firings'])
-test('T21148', [grep_errmsg(r'Cpr=') ], compile, ['-O -ddump-simpl'])
# One module, T21851.hs, has OPTIONS_GHC -ddump-simpl
test('T21851', [grep_errmsg(r'case.*w\$sf') ], multimod_compile, ['T21851', '-O -dno-typeable-binds -dsuppress-uniques'])
=====================================
testsuite/tests/stranal/should_compile/T21128.hs
=====================================
@@ -2,10 +2,6 @@ module T21128 where
import T21128a
-{- This test originally had some unnecessary reboxing of y
-in the hot path of $wtheresCrud. That reboxing should
-not happen. -}
-
theresCrud :: Int -> Int -> Int
theresCrud x y = go x
where
@@ -13,4 +9,3 @@ theresCrud x y = go x
go 1 = index x y 1
go n = go (n-1)
{-# NOINLINE theresCrud #-}
-
=====================================
testsuite/tests/stranal/should_compile/T21128.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 125, types: 68, coercions: 4, joins: 0/0}
+ = {terms: 137, types: 92, coercions: 4, joins: 0/0}
lvl = "error"#
@@ -29,11 +29,17 @@ lvl9 = SrcLoc lvl2 lvl3 lvl5 lvl6 lvl7 lvl6 lvl8
lvl10 = PushCallStack lvl1 lvl9 EmptyCallStack
+$windexError
+ = \ @a @b ww eta eta1 eta2 ->
+ error
+ (lvl10 `cast` <Co:4> :: CallStack ~R# (?callStack::CallStack))
+ (++ (ww eta) (++ (ww eta1) (ww eta2)))
+
indexError
= \ @a @b $dShow eta eta1 eta2 ->
- error
- (lvl10 `cast` <Co:4> :: ...)
- (++ (show $dShow eta) (++ (show $dShow eta1) (show $dShow eta2)))
+ case $dShow of { C:Show ww ww1 ww2 ->
+ $windexError ww1 eta eta1 eta2
+ }
$trModule3 = TrNameS $trModule4
@@ -42,7 +48,8 @@ $trModule1 = TrNameS $trModule2
$trModule = Module $trModule3 $trModule1
$wlvl
- = \ ww ww1 ww2 -> indexError $fShowInt (I# ww2) (I# ww1) (I# ww)
+ = \ ww ww1 ww2 ->
+ $windexError $fShowInt_$cshow (I# ww2) (I# ww1) (I# ww)
index
= \ l u i ->
@@ -66,7 +73,7 @@ index
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 108, types: 46, coercions: 0, joins: 3/3}
+ = {terms: 108, types: 47, coercions: 0, joins: 3/4}
$trModule4 = "main"#
@@ -82,34 +89,35 @@ i = I# 1#
l = I# 0#
-lvl = \ x ww -> indexError $fShowInt x (I# ww) i
+lvl = \ y -> $windexError $fShowInt_$cshow l y l
-lvl1 = \ ww -> indexError $fShowInt l (I# ww) l
+lvl1 = \ ww y -> $windexError $fShowInt_$cshow (I# ww) y i
$wtheresCrud
= \ ww ww1 ->
+ let { y = I# ww1 } in
join {
- exit
- = case <# 0# ww1 of {
- __DEFAULT -> case lvl1 ww1 of wild { };
- 1# -> 0#
- } } in
- join {
- exit1
+ lvl2
= case <=# ww 1# of {
- __DEFAULT -> case lvl (I# ww) ww1 of wild { };
+ __DEFAULT -> case lvl1 ww y of wild { };
1# ->
case <# 1# ww1 of {
- __DEFAULT -> case lvl (I# ww) ww1 of wild { };
+ __DEFAULT -> case lvl1 ww y of wild { };
1# -> -# 1# ww
}
} } in
+ join {
+ lvl3
+ = case <# 0# ww1 of {
+ __DEFAULT -> case lvl y of wild { };
+ 1# -> 0#
+ } } in
joinrec {
$wgo ww2
= case ww2 of wild {
__DEFAULT -> jump $wgo (-# wild 1#);
- 0# -> jump exit;
- 1# -> jump exit1
+ 0# -> jump lvl3;
+ 1# -> jump lvl2
}; } in
jump $wgo ww
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/22085bcdf8b5ebf8e8a9b30fb74fbe400616c12c...d5b5c07c71ecb652d4594e5d6eddfdd28d4f060c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/22085bcdf8b5ebf8e8a9b30fb74fbe400616c12c...d5b5c07c71ecb652d4594e5d6eddfdd28d4f060c
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/20230208/a8c65dd3/attachment-0001.html>
More information about the ghc-commits
mailing list