[Git][ghc/ghc][wip/T22924] 5 commits: JS: avoid head/tail and unpackFS
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Feb 8 22:45:49 UTC 2023
Simon Peyton Jones pushed to branch wip/T22924 at Glasgow Haskell Compiler / GHC
Commits:
c1670c6b by Sylvain Henry at 2023-02-07T21:25:18-05:00
JS: avoid head/tail and unpackFS
- - - - -
a9912de7 by Krzysztof Gogolewski at 2023-02-07T21:25:53-05:00
testsuite: Fix Python warnings (#22856)
- - - - -
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
-------------------------
- - - - -
c8d18d0a by Simon Peyton Jones at 2023-02-08T22:46:35+00:00
Narrow the dont-decompose-newtype test
Following #22924 this patch narrows the test that stops
us decomposing newtypes.
This makes Note [Unwrap newtypes first], Case 1, seem very narrow and
contrived: doing newtype unwrapping in the rewriter no longer looks as
helpful as it did in #22519. But it does no harm so I'm leaving it
in.
- - - - -
19 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/Rename/Bind.hs
- compiler/GHC/StgToJS/Printer.hs
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- testsuite/driver/runtests.py
- testsuite/driver/testlib.py
- + 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/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
=====================================
compiler/GHC/StgToJS/Printer.hs
=====================================
@@ -108,19 +108,17 @@ ghcjsRenderJsV r (JHash m)
where
quoteIfRequired :: FastString -> Doc
quoteIfRequired x
- | isUnquotedKey x' = text x'
- | otherwise = PP.squotes (text x')
- where x' = unpackFS x
-
- isUnquotedKey :: String -> Bool
- isUnquotedKey x | null x = False
- | all isDigit x = True
- | otherwise = validFirstIdent (head x)
- && all validOtherIdent (tail x)
+ | isUnquotedKey x = ftext x
+ | otherwise = PP.squotes (ftext x)
+ isUnquotedKey :: FastString -> Bool
+ isUnquotedKey fs = case unpackFS fs of
+ [] -> False
+ s@(c:cs) -> all isDigit s || (validFirstIdent c && all validOtherIdent cs)
validFirstIdent c = c == '_' || c == '$' || isAlpha c
validOtherIdent c = isAlpha c || isDigit c
+
ghcjsRenderJsV r v = renderJsV defaultRenderJs r v
prettyBlock :: RenderJs -> [JStat] -> Doc
=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -1409,10 +1409,10 @@ in `can_eq_newtype_nc`
But even this is challenging. Here are two cases to consider:
-Case 1:
+Case 1 (extremely contrived):
newtype Age = MkAge Int
- [G] c
+ [G] IO s ~ IO t -- where s,t ane not Age,Int
[W] w1 :: IO Age ~R# IO Int
Case 2:
@@ -1422,9 +1422,9 @@ Case 2:
For Case 1, recall that IO is an abstract newtype. Then read Note
[Decomposing newtype equalities]. According to that Note, we should not
-decompose w1, because we have an Irred Given. Yet we still want to solve
-the wanted! We can do so by unwrapping the (non-abstract) Age newtype
-underneath the IO, giving
+decompose w1, because we have an Irred Given that stops decomposition.
+Yet we still want to solve the wanted! We can do so by unwrapping the
+(non-abstract) Age newtype underneath the IO, giving
[W] w2 :: IO Int ~R# IO Int
w1 = (IO unwrap-Age ; w2)
where unwrap-Age :: Age ~R# Int. Now we case solve w2 by reflexivity;
@@ -1641,7 +1641,7 @@ canTyConApp rewritten ev eq_rel tc1 tys1 tc2 tys2
ty2 = mkTyConApp tc2 tys2
-- See Note [Decomposing TyConApp equalities]
- -- Note [Decomposing newtypes a bit more aggressively]
+ -- and Note [Decomposing newtype equalities]
can_decompose inerts
= isInjectiveTyCon tc1 (eqRelRole eq_rel)
|| (assert (eq_rel == ReprEq) $
@@ -1650,7 +1650,8 @@ canTyConApp rewritten ev eq_rel tc1 tys1 tc2 tys2
-- Moreover isInjectiveTyCon is True for Representational
-- for algebraic data types. So we are down to newtypes
-- and data families.
- ctEvFlavour ev == Wanted && noGivenIrreds inerts)
+ ctEvFlavour ev == Wanted && noGivenNewtypeReprEqs tc1 inerts)
+ -- See Note [Decomposing newtype equalities] (EX2)
{-
Note [Use canEqFailure in canDecomposableTyConApp]
@@ -1856,7 +1857,7 @@ Conclusion: decompose newtypes (at role R) only if there are no usable Givens.
Conclusion: always unwrap newtypes before attempting to decompose
them. This is done in can_eq_nc'. Of course, we can't unwrap if the data
- constructor isn't in scope. See See Note [Unwrap newtypes first].
+ constructor isn't in scope. See Note [Unwrap newtypes first].
* Incompleteness example (EX2)
newtype Nt a = Mk Bool -- NB: a is not used in the RHS,
@@ -1864,31 +1865,51 @@ Conclusion: decompose newtypes (at role R) only if there are no usable Givens.
If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to
[W] alpha ~R beta, because it's possible that alpha and beta aren't
- representationally equal.
-
- and maybe there is a Given (Nt t1 ~R Nt t2), just waiting to be used, if we
- figure out (elsewhere) that alpha:=t1 and beta:=t2. This is somewhat
- similar to the question of overlapping Givens for class constraints: see
- Note [Instance and Given overlap] in GHC.Tc.Solver.Interact.
+ representationally equal. And maybe there is a Given (Nt t1 ~R Nt t2),
+ just waiting to be used, if we figure out (elsewhere) that alpha:=t1
+ and beta:=t2. This is somewhat similar to the question of overlapping
+ Givens for class constraints: see Note [Instance and Given overlap]
+ in GHC.Tc.Solver.Interact.
Conclusion: don't decompose [W] N s ~R N t, if there are any Given
equalities that could later solve it.
- But what does "any Given equalities that could later solve it" mean, precisely?
- It must be a Given constraint that could turn into N s ~ N t. But that
- could include [G] (a b) ~ (c d), or even just [G] c. But it'll definitely
- be an CIrredCan. So we settle for having no CIrredCans at all, which is
- conservative but safe. See noGivenIrreds and #22331.
+ But what precisely does "any Given equalities that could later solve it" mean?
+
+ It must be a Given constraint that could turn into N s ~ N t.
+ That could /in principle/ include [G] (a b) ~ (c d), or even just [G] c.
+ But since the free vars of a Given are skolems, or at least untouchable
+ unification variables, it is extremely unlikely that such Givens
+ will "turn into" [G] N s ~ N t.
+
+ Moreover, in #22908 we had
+ [G] f a ~R# a [W] Const (f a) a ~R# Const a a
+ where Const is a newtype. If we decomposed the newtype, we could solve.
+ Not-decomposing on the grounds that (f a ~R# a) might turn into
+ (Const (f a) a ~R# Const a a) seems a bit silly.
+
+ The currently-implemented compromise is this:
+
+ we decompose [W] N s ~R# N t unless there is a [G] N s' ~ N t'
+
+ that is, a Given Irred equality with both sides headed with N.
+ See the call to noGivenNewtypeReprEqs in canTyConApp.
+
+ This is still incomplete but only just, and there is no perfect answer.
+ See #22331 and #22908.
+
+ We only look at Irreds. There could, just, be a CDictCan with some
+ un-expanded equality superclasses; but only in some very obscure
+ recursive-superclass situations.
- Well not 100.0% safe. There could be a CDictCan with some un-expanded
- superclasses; but only in some very obscure recursive-superclass
- situations.
+ Now suppose we have [G] IO t1 ~R# IO t2, [W] IO Age ~R# IO Int,
+ where t1, t2 are not actually Age, Int. Then noGiveNewtypeReprEqs
+ will stop us decomposing the Wanted (IO is a newtype). But we
+ can /still/ win by unwrapping the newtype Age in the rewriter:
+ see Note [Unwrap newtypes first]
-If there are no Irred Givens (which is quite common) then we will
-successfuly decompose [W] (IO Age) ~R (IO Int), and solve it. But
-that won't happen and [W] (IO Age) ~R (IO Int) will be stuck.
-We /could/, however, be a bit more aggressive about decomposition;
-see Note [Decomposing newtypes a bit more aggressively].
+ Yet another approach (!) is desribed in
+ Note [Decomposing newtypes a bit more aggressively].
Remember: decomposing Wanteds is always /sound/. This Note is
only about /completeness/.
@@ -1896,7 +1917,8 @@ only about /completeness/.
Note [Decomposing newtypes a bit more aggressively]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
IMPORTANT: the ideas in this Note are *not* implemented. Instead, the
-current approach is detailed in Note [Unwrap newtypes first].
+current approach is detailed in Note [Decomposing newtype equalities]
+and Note [Unwrap newtypes first].
For more details about the ideas in this Note see
* GHC propoosal: https://github.com/ghc-proposals/ghc-proposals/pull/549
* issue #22441
=====================================
compiler/GHC/Tc/Solver/InertSet.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Tc.Solver.InertSet (
addInertItem,
noMatchableGivenDicts,
- noGivenIrreds,
+ noGivenNewtypeReprEqs,
mightEqualLater,
prohibitedSuperClassSolve,
@@ -1537,9 +1537,22 @@ isOuterTyVar tclvl tv
-- becomes "outer" even though its level numbers says it isn't.
| otherwise = False -- Coercion variables; doesn't much matter
-noGivenIrreds :: InertSet -> Bool
-noGivenIrreds (IS { inert_cans = inert_cans })
- = isEmptyBag (inert_irreds inert_cans)
+noGivenNewtypeReprEqs :: TyCon -> InertSet -> Bool
+-- True <=> there is no Irred looking like (N tys1 ~ N tys2)
+-- See Note [Decomposing newtype equalities] (EX2) in GHC.Tc.Solver.Canonical
+-- This is the only call site.
+noGivenNewtypeReprEqs tc inerts
+ = not (anyBag might_help (inert_irreds (inert_cans inerts)))
+ where
+ might_help ct
+ = case classifyPredType (ctPred ct) of
+ EqPred ReprEq t1 t2
+ | Just (tc1,_) <- tcSplitTyConApp_maybe t1
+ , tc == tc1
+ , Just (tc2,_) <- tcSplitTyConApp_maybe t2
+ , tc == tc2
+ -> True
+ _ -> False
-- | Returns True iff there are no Given constraints that might,
-- potentially, match the given class consraint. This is used when checking to see if a
=====================================
testsuite/driver/runtests.py
=====================================
@@ -601,6 +601,7 @@ else:
if args.junit:
junit(t).write(args.junit)
+ args.junit.close()
if config.only_report_hadrian_deps:
print("WARNING - skipping all tests and only reporting required hadrian dependencies:", config.hadrian_deps)
=====================================
testsuite/driver/testlib.py
=====================================
@@ -1347,7 +1347,7 @@ def do_test(name: TestName,
# if found and instead have the testsuite decide on what to do
# with the output.
def override_options(pre_cmd):
- if config.verbose >= 5 and bool(re.match('\$make', pre_cmd, re.I)):
+ if config.verbose >= 5 and bool(re.match(r'\$make', pre_cmd, re.I)):
return pre_cmd.replace(' -s' , '') \
.replace('--silent', '') \
.replace('--quiet' , '')
@@ -1989,7 +1989,7 @@ def split_file(in_fn: Path, delimiter: str, out1_fn: Path, out2_fn: Path):
with out1_fn.open('w', encoding='utf8', newline='') as out1:
with out2_fn.open('w', encoding='utf8', newline='') as out2:
line = infile.readline()
- while re.sub('^\s*','',line) != delimiter and line != '':
+ while re.sub(r'^\s*','',line) != delimiter and line != '':
out1.write(line)
line = infile.readline()
@@ -2399,20 +2399,20 @@ def normalise_errmsg(s: str) -> str:
# warning message to get clean output.
if config.msys:
s = re.sub('Failed to remove file (.*); error= (.*)$', '', s)
- s = re.sub('DeleteFile "(.+)": permission denied \(Access is denied\.\)(.*)$', '', s)
+ s = re.sub(r'DeleteFile "(.+)": permission denied \(Access is denied\.\)(.*)$', '', s)
# filter out unsupported GNU_PROPERTY_TYPE (5), which is emitted by LLVM10
# and not understood by older binutils (ar, ranlib, ...)
- s = modify_lines(s, lambda l: re.sub('^(.+)warning: (.+): unsupported GNU_PROPERTY_TYPE \(5\) type: 0xc000000(.*)$', '', l))
+ s = modify_lines(s, lambda l: re.sub(r'^(.+)warning: (.+): unsupported GNU_PROPERTY_TYPE \(5\) type: 0xc000000(.*)$', '', l))
- s = re.sub('ld: warning: passed .* min versions \(.*\) for platform macOS. Using [\.0-9]+.','',s)
+ s = re.sub(r'ld: warning: passed .* min versions \(.*\) for platform macOS. Using [\.0-9]+.','',s)
s = re.sub('ld: warning: -sdk_version and -platform_version are not compatible, ignoring -sdk_version','',s)
# ignore superfluous dylibs passed to the linker.
s = re.sub('ld: warning: .*, ignoring unexpected dylib file\n','',s)
# ignore LLVM Version mismatch garbage; this will just break tests.
s = re.sub('You are using an unsupported version of LLVM!.*\n','',s)
- s = re.sub('Currently only [\.0-9]+ is supported. System LLVM version: [\.0-9]+.*\n','',s)
- s = re.sub('We will try though\.\.\..*\n','',s)
+ s = re.sub('Currently only [\\.0-9]+ is supported. System LLVM version: [\\.0-9]+.*\n','',s)
+ s = re.sub('We will try though\\.\\.\\..*\n','',s)
# ignore warning about strip invalidating signatures
s = re.sub('.*strip: changes being made to the file will invalidate the code signature in.*\n','',s)
# clang may warn about unused argument when used as assembler
@@ -2475,8 +2475,8 @@ def normalise_slashes_( s: str ) -> str:
return s
def normalise_exe_( s: str ) -> str:
- s = re.sub('\.exe', '', s)
- s = re.sub('\.jsexe', '', s)
+ s = re.sub(r'\.exe', '', s)
+ s = re.sub(r'\.jsexe', '', s)
return s
def normalise_output( s: str ) -> str:
@@ -2494,14 +2494,14 @@ def normalise_output( s: str ) -> str:
# ghci outputs are pretty unstable with -fexternal-dynamic-refs, which is
# requires for -fPIC
s = re.sub(' -fexternal-dynamic-refs\n','',s)
- s = re.sub('ld: warning: passed .* min versions \(.*\) for platform macOS. Using [\.0-9]+.','',s)
+ s = re.sub(r'ld: warning: passed .* min versions \(.*\) for platform macOS. Using [\.0-9]+.','',s)
s = re.sub('ld: warning: -sdk_version and -platform_version are not compatible, ignoring -sdk_version','',s)
# ignore superfluous dylibs passed to the linker.
s = re.sub('ld: warning: .*, ignoring unexpected dylib file\n','',s)
# ignore LLVM Version mismatch garbage; this will just break tests.
s = re.sub('You are using an unsupported version of LLVM!.*\n','',s)
- s = re.sub('Currently only [\.0-9]+ is supported. System LLVM version: [\.0-9]+.*\n','',s)
- s = re.sub('We will try though\.\.\..*\n','',s)
+ s = re.sub('Currently only [\\.0-9]+ is supported. System LLVM version: [\\.0-9]+.*\n','',s)
+ s = re.sub('We will try though\\.\\.\\..*\n','',s)
# ignore warning about strip invalidating signatures
s = re.sub('.*strip: changes being made to the file will invalidate the code signature in.*\n','',s)
# clang may warn about unused argument when used as assembler
=====================================
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/2b7bb2defad8e4d9ceb58f38db240b0e6f3967c3...c8d18d0a3ecae86a97573e42d16121cf0c882d7b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b7bb2defad8e4d9ceb58f38db240b0e6f3967c3...c8d18d0a3ecae86a97573e42d16121cf0c882d7b
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/83c00c29/attachment-0001.html>
More information about the ghc-commits
mailing list