- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/andreask/fold_tag_to_enum] Simplifier: Constant fold invald tagToEnum# calls to bottom expr.
by Andreas Klebinger (＠AndreasK) 22 Apr '25

22 Apr '25

Andreas Klebinger pushed to branch wip/andreask/fold_tag_to_enum at Glasgow Haskell Compiler / GHC Commits: 2e204269 by Andreas Klebinger at 2025-04-22T12:20:41+02:00 Simplifier: Constant fold invald tagToEnum# calls to bottom expr. When applying tagToEnum# to a out-of-range value it's best to simply constant fold it to a bottom expression. That potentially allows more dead code elimination and makes debugging easier. Fixes #25976 - - - - - 3 changed files: - compiler/GHC/Core/Opt/ConstantFold.hs - + testsuite/tests/simplCore/should_compile/T25976.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -69,7 +69,6 @@ import GHC.Cmm.MachOp ( FMASign(..) ) import GHC.Cmm.Type ( Width(..) ) import GHC.Data.FastString -import GHC.Data.Maybe ( orElse ) import GHC.Utils.Outputable import GHC.Utils.Misc @@ -1997,6 +1996,14 @@ because we don't expect the user to call tagToEnum# at all; we merely generate calls in derived instances of Enum. So we compromise: a rewrite rule rewrites a bad instance of tagToEnum# to an error call, and emits a warning. + +We also do something similar if we can see that the argument of tagToEnum is out +of bounds, e.g. `tagToEnum# 99# :: Bool`. +Replacing this with an error expression is better for two reasons: +* It allow us to eliminate more dead code in cases like `case tagToEnum# 99# :: Bool of ...` +* Should we actually end up executing the relevant code at runtime the user will + see a meaningful error message, instead of a segfault or incorrect result. +See #25976. -} tagToEnumRule :: RuleM CoreExpr @@ -2008,9 +2015,13 @@ tagToEnumRule = do Just (tycon, tc_args) | isEnumerationTyCon tycon -> do let tag = fromInteger i correct_tag dc = (dataConTagZ dc) == tag - (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) - massert (null rest) - return $ mkTyApps (Var (dataConWorkId dc)) tc_args + Just dataCons <- pure $ tyConDataCons_maybe tycon + case filter correct_tag dataCons of + (dc:rest) -> do + massert (null rest) + pure $ mkTyApps (Var (dataConWorkId dc)) tc_args + -- Literal is out of range, e.g. tagToEnum @Bool #4 + [] -> pure $ mkImpossibleExpr ty "tagToEnum: Argument out of range" -- See Note [tagToEnum#] _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $ ===================================== testsuite/tests/simplCore/should_compile/T25976.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE MagicHash #-} + +module T25976 where + +import GHC.PrimOps (tagToEnum#) + +-- Spoiler - it's all dead code since tagToEnum 3# is undefined +main = case (tagToEnum# 4# :: Bool) of + True -> print "Dead Code" + False -> print "Dead Code" ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -541,3 +541,5 @@ test('T25883', normal, compile_grep_core, ['']) test('T25883b', normal, compile_grep_core, ['']) test('T25883c', normal, compile_grep_core, ['']) test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, ['T25883d', '-O -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques', r'grep -e "y ="']) + +test('T25976', [grep_errmsg('Dead Code')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2e2042693ace5f7e857315b40750f02… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2e2042693ace5f7e857315b40750f02… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109] 2 commits: Implement unary classes
by Simon Peyton Jones (＠simonpj) 22 Apr '25

22 Apr '25

Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC Commits: ed147b3b by Simon Peyton Jones at 2025-04-22T10:45:40+01:00 Implement unary classes The big change is described exhaustively in Note [Unary class magic] in GHC.Core.TyCon Other changes * We never unbox class dictionaries in worker/wrapper. This has been true for some time now, but the logic is now centralised in functions in GHC.Core.Opt.WorkWrap.Utils, namely `canUnboxTyCon`, and `canUnboxArg` See Note [Do not unbox class dictionaries] in GHC.Core.Opt.WorkWrap.Utils. * Refactored the `notWorthFloating` logic in GHc.Core.Opt.SetLevels. I can't remember if I actually changed any behaviour here, but if so it's only in a corner cases. * Fixed a bug in `GHC.Core.TyCon.isEnumerationTyCon`, which was wrongly returning True for (##). * Remove redundant Role argument to `liftCoSubstWithEx`. It was always Representational. * I refactored evidence generation in the constraint solver: * Made GHC.Tc.Types.Evidence contain better abstactions for evidence generation. * I deleted the file `GHC.Tc.Types.EvTerm` and merged its (small) contents elsewhere. It wasn't paying its way. * Made evidence for implicit parameters go via a proper abstraction. Smaller things * Rename `isDataTyCon` to `isBoxedDataTyCon`. * GHC.Core.Corecion.liftCoSubstWithEx was only called with Representational role, so I baked that into the function and removed the argument. * Get rid of `GHC.Core.TyCon.tyConSingleAlgDataCon_maybe` in favour of calling `not isNewTyCon` at the call sites; more explicit. * Refatored `GHC.Core.TyCon.isInjectiveTyCon`; but I don't think I changed its behaviour * Moved `decomposeIPPred` to GHC.Core.Predicate - - - - - b11e6298 by Simon Peyton Jones at 2025-04-22T10:47:59+01:00 Fix infelicities in the Specialiser On the way to #23109 (unary classes) I discovered some infelicities (or maybe tiny bugs, I forget) in the type-class specialiser. I also tripped over #25965, an outright bug in the rule matcher Specifically: * Refactor: I enhanced `wantCallsFor`, whih previously always said `True`, to discard calls of class-ops, data constructors etc. This is a bit more efficient; and it means we don't need to worry about filtering them out later. * Fix: I tidied up some tricky logic that eliminated redundant specialisations. It wasn't working correctly. See the expanded Note [Specialisations already covered], and (MP3) in Note [Specialising polymorphic dictionaries]. See also the new top-level `alreadyCovered` function, which now goes via `GHC.Core.Rules.ruleLhsIsMoreSpecific` I also added a useful Note [The (CI-KEY) invariant] * Fix #25965: fixed a tricky bug in the `go_fam_fam` in `GHC.Core.Unify.uVarOrFam`, which allows matching to succeed without binding all type varibles. I enhanced Note [Apartness and type families] some more * #25703. This ticket "just works" with -fpolymorphic-specialisation; but I was surprised that it worked! In this MR I added documentation to Note [Interesting dictionary arguments] to explain; and tests to ensure it stays fixed. - - - - - 91 changed files: - compiler/GHC/Builtin/Types.hs - compiler/GHC/Core/Class.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Unfold/Make.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Foreign/Call.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - − compiler/GHC/Tc/Types/EvTerm.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs - compiler/ghc.cabal.in - testsuite/tests/core-to-stg/T24124.stderr - testsuite/tests/deSugar/should_compile/T2431.stderr - testsuite/tests/dependent/should_fail/T13135_simple.stderr - testsuite/tests/dmdanal/should_compile/T16029.stdout - testsuite/tests/dmdanal/sigs/T21119.stderr - testsuite/tests/dmdanal/sigs/T21888.stderr - testsuite/tests/indexed-types/should_compile/T2238.hs - testsuite/tests/numeric/should_compile/T15547.stderr - testsuite/tests/numeric/should_compile/T23907.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/simplCore/should_compile/DataToTagFamilyScrut.stderr - testsuite/tests/simplCore/should_compile/T15205.stderr - testsuite/tests/simplCore/should_compile/T17366.stderr - testsuite/tests/simplCore/should_compile/T17966.stderr - testsuite/tests/simplCore/should_compile/T22309.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr - testsuite/tests/simplCore/should_compile/T23307.stderr - testsuite/tests/simplCore/should_compile/T23307a.stderr - testsuite/tests/simplCore/should_compile/T25389.stderr - + testsuite/tests/simplCore/should_compile/T25703.hs - + testsuite/tests/simplCore/should_compile/T25703.stderr - + testsuite/tests/simplCore/should_compile/T25703a.hs - + testsuite/tests/simplCore/should_compile/T25703a.stderr - testsuite/tests/simplCore/should_compile/T25713.stderr - + testsuite/tests/simplCore/should_compile/T25965.hs - testsuite/tests/simplCore/should_compile/T7360.stderr - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/simplStg/should_compile/T15226b.stderr - testsuite/tests/tcplugins/CtIdPlugin.hs - testsuite/tests/typecheck/should_compile/Makefile - testsuite/tests/typecheck/should_compile/T12763.stderr - testsuite/tests/typecheck/should_compile/T14774.stdout - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/unboxedsums/unpack_sums_7.stdout - testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c713feed52fdf0a5ede45fa7cbda98… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c713feed52fdf0a5ede45fa7cbda98… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] Import wibble
by Simon Peyton Jones (＠simonpj) 22 Apr '25

22 Apr '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: 64a48355 by Simon Peyton Jones at 2025-04-22T10:33:02+01:00 Import wibble - - - - - 1 changed file: - compiler/GHC/Core/Opt/OccurAnal.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -55,7 +55,7 @@ import GHC.Types.Tickish import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Var -import GHC.Types.Demand ( argOneShots, argsOneShots, isDeadEndSig ) +import GHC.Types.Demand ( argOneShots, argsOneShots {- , isDeadEndSig -} ) import GHC.Utils.Outputable import GHC.Utils.Panic View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64a4835510365cfc295ad8b85fdd725… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64a4835510365cfc295ad8b85fdd725… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25440] Fix hetero kinded solving
by Simon Peyton Jones (＠simonpj) 22 Apr '25

22 Apr '25

Simon Peyton Jones pushed to branch wip/T25440 at Glasgow Haskell Compiler / GHC Commits: 83430c77 by Simon Peyton Jones at 2025-04-22T10:12:08+01:00 Fix hetero kinded solving - - - - - 1 changed file: - compiler/GHC/Tc/Solver/Equality.hs Changes: ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -1604,7 +1604,7 @@ canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2) -> TcType -> TcType -- xi2 -> TcKind -- ki2 -> TcS (StopOrContinue (Either IrredCt EqCt)) -canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 _ps_xi2 ki2 +canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 -- See Note [Equalities with incompatible kinds] -- See Note [Kind Equality Orientation] @@ -1613,60 +1613,63 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 _ps_xi2 ki2 -- NotSwapped: -- ev :: (lhs1:ki1) ~r# (xi2:ki2) -- kind_co :: k11 ~# ki2 -- Same orientation as ev --- type_ev :: lhs1 ~r# (xi2 |> sym kind_co) +-- new_ev :: lhs1 ~r# (xi2 |> sym kind_co) -- Swapped -- ev :: (xi2:ki2) ~r# (lhs1:ki1) -- kind_co :: ki2 ~# ki1 -- Same orientation as ev --- type_ev :: (xi2 |> kind_co) ~r# lhs1 +-- new_ev :: (xi2 |> kind_co) ~r# lhs1 +-- Note that we need the `sym` when we are /not/ swapped; hence `mk_sym_co` - = do { (kind_co, rewriters, unifs_happened) <- mk_kind_eq -- :: ki1 ~N ki2 - ; if unifs_happened - -- Unifications happened, so start again to do the zonking - -- Otherwise we might put something in the inert set that isn't inert - then startAgainWith (mkNonCanonical ev) - else - assertPpr (not (isEmptyRewriterSet rewriters)) (ppr ev) $ - -- The rewriter set won't be empty because the two kinds differ, and there - -- are no unifications, so we must have emitted one or more constraints - do { let lhs_redn = mkReflRedn role ps_xi1 - rhs_redn = mkGReflRightRedn role xi2 mb_sym_kind_co - mb_sym_kind_co = case swapped of - NotSwapped -> mkSymCo kind_co - IsSwapped -> kind_co - - ; traceTcS "Hetero equality gives rise to kind equality" - (ppr swapped $$ - ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ]) - ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn - - -- The rewritten equality is non-canonical, so put it straight in the Irreds - ; finishCanWithIrred (NonCanonicalReason (cteProblem cteCoercionHole)) type_ev } } - --- ; let new_xi2 = mkCastTy ps_xi2 mb_sym_kind_co --- ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 }} - - where - mk_kind_eq :: TcS (CoercionN, RewriterSet, Bool) - -- Returned kind_co has kind (k1 ~ k2) if NotSwapped, (k2 ~ k1) if Swapped - -- Returned Bool = True if unifications happened, so we should retry - mk_kind_eq = case ev of + = case ev of CtGiven (GivenCt { ctev_evar = evar, ctev_loc = loc }) -> do { let kind_co = mkKindCo (mkCoVarCo evar) pred_ty = unSwap swapped mkNomEqPred ki1 ki2 kind_loc = mkKindEqLoc xi1 xi2 loc ; kind_ev <- newGivenEvVar kind_loc (pred_ty, evCoercion kind_co) ; emitWorkNC [CtGiven kind_ev] - ; return (givenCtEvCoercion kind_ev, emptyRewriterSet, False) } + ; let kind_co = givenCtEvCoercion kind_ev + new_xi2 = mkCastTy ps_xi2 (mk_sym_co kind_co) + ; new_ev <- do_rewrite emptyRewriterSet kind_co + -- In the Given case, `new_ev` is canonical, so carry on + ; canEqCanLHSHomo new_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 } CtWanted {} - -> do { (kind_co, cts, unifs) <- wrapUnifierTcS ev Nominal $ \uenv -> - let uenv' = updUEnvLoc uenv (mkKindEqLoc xi1 xi2) - in unSwap swapped (uType uenv') ki1 ki2 - ; return (kind_co, rewriterSetFromCts cts, not (null unifs)) } - + -> do { (kind_co, cts, unifs) <- wrapUnifierTcS ev Nominal $ \uenv -> + let uenv' = updUEnvLoc uenv (mkKindEqLoc xi1 xi2) + in unSwap swapped (uType uenv') ki1 ki2 + ; if not (null unifs) + then -- Unifications happened, so start again to do the zonking + -- Otherwise we might put something in the inert set that isn't inert + startAgainWith (mkNonCanonical ev) + else + + assertPpr (not (isEmptyCts cts)) (ppr ev $$ ppr ki1 $$ ppr ki2) $ + -- The constraints won't be empty because the two kinds differ, and there + -- are no unifications, so we must have emitted one or more constraints + do { new_ev <- do_rewrite (rewriterSetFromCts cts) kind_co + -- The rewritten equality `new_ev` is non-canonical, + -- so put it straight in the Irreds + ; finishCanWithIrred (NonCanonicalReason (cteProblem cteCoercionHole)) new_ev } } + where xi1 = canEqLHSType lhs1 role = eqRelRole eq_rel + -- Apply mkSymCo when /not/ swapped + mk_sym_co co = case swapped of + NotSwapped -> mkSymCo co + IsSwapped -> co + + do_rewrite rewriters kind_co + = do { traceTcS "Hetero equality gives rise to kind equality" + (ppr swapped $$ + ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ]) + ; rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn } + where + -- kind_co :: ki1 ~N ki2 + lhs_redn = mkReflRedn role ps_xi1 + rhs_redn = mkGReflRightRedn role xi2 (mk_sym_co kind_co) + + canEqCanLHSHomo :: CtEvidence -- lhs ~ rhs -- or, if swapped: rhs ~ lhs -> EqRel -> SwapFlag View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83430c7783133ae778d237975d4a831… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83430c7783133ae778d237975d4a831… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] Small wibbles
by Simon Peyton Jones (＠simonpj) 22 Apr '25

22 Apr '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: 448a7bbc by Simon Peyton Jones at 2025-04-22T09:53:44+01:00 Small wibbles Don't make error calls interesting. Literals say True too isSaturatedConApp - - - - - 4 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Utils.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2580,8 +2580,9 @@ occAnalArgs !env fun args !one_shots -- Make bottoming functions interesting -- See Note [Bottoming function calls] - encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut - | otherwise = OccVanilla +-- encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut +-- | otherwise = OccVanilla + encl = OccVanilla go uds fun [] _ = WUD uds fun go uds fun (arg:args) one_shots @@ -2617,6 +2618,9 @@ setting occ_encl = OccScrut for such calls. The slightly-artificial test T21128 is a good example. It's probably not a huge deal. +ToDo!!! Fix comment. Now postinlineUnconditionally ignores intersting-ness for +non-top-level things. + Note [Arguments of let-bound constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -707,7 +707,7 @@ lvlMFE env strict_ctxt ann_expr escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env) -- See Note [Floating to the top] - is_con_app = isSaturatedConApp expr + is_con_app = isSaturatedConApp expr -- True of literal strings too saves_alloc = isTopLvl dest_lvl && (escapes_value_lam || floatConsts env) -- Always float allocation out of a value lambda @@ -719,7 +719,7 @@ lvlMFE env strict_ctxt ann_expr -- If we float, then eta-expand we get -- lvl = (++) ys -- f = \x \zs -> lvl zs - -- and now wei'll inline lvl. Silly. + -- and now we'll inline lvl. Silly. hasFreeJoin :: LevelEnv -> DVarSet -> Bool ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1619,8 +1619,6 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br } | exprIsTrivial rhs -> True --- | is_top_lvl -> False --- Inlining a top-level used-once function is good | otherwise -> check_one_occ in_lam int_cxt n_br IAmDead -> True -- This happens; for example, the case_bndr during case of ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -397,10 +397,12 @@ mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks isSaturatedConApp :: CoreExpr -> Bool +-- Also includes literals isSaturatedConApp e = go e [] where go (App f a) as = go f (a:as) go (Var fun) args = isConLikeId fun && idArity fun == valArgCount args + go (Lit {}) _ = True go (Cast f _) as = go f as go _ _ = False View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/448a7bbcc48acb64a75622786711ab7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/448a7bbcc48acb64a75622786711ab7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T24603] Bisect attempt for ghc js backend
by Serge S. Gulin (＠gulin.serge) 22 Apr '25

22 Apr '25

Serge S. Gulin pushed to branch wip/T24603 at Glasgow Haskell Compiler / GHC Commits: c73fbb5a by Serge S. Gulin at 2025-04-22T10:19:10+03:00 Bisect attempt for ghc js backend submodule - - - - - 1 changed file: - libraries/Cabal Changes: ===================================== libraries/Cabal ===================================== @@ -1 +1 @@ -Subproject commit 703582f80f6d7f0c914ef4b885affcfc7b7b6ec8 +Subproject commit 26f1cd7a3a01ad5c5bdfd8a240654e9233bc298a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c73fbb5a8951b2198bbb201d1c47548… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c73fbb5a8951b2198bbb201d1c47548… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] filter expr stmts error msgs
by Apoorv Ingle (＠ani) 22 Apr '25

22 Apr '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 59b20112 by Apoorv Ingle at 2025-04-22T00:27:16-05:00 filter expr stmts error msgs - - - - - 1 changed file: - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1226,14 +1226,14 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) -- | Add a fixed message to the error context. This message should not -- do any tidying. --- no op in generated code +-- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. --- no op in generated code +-- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] @@ -1720,9 +1720,26 @@ mkErrCtxt env ctxts -- then return empty -- just becomes too voluminous -- else go dbg 0 env ctxts = go False 0 env ctxts + where go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] go _ _ _ [] = return [] + go dbg n env ((is_landmark1, ctxt1) : (is_landmark2, ctxt2) : ctxts) + | is_landmark1 || n < mAX_CONTEXTS -- Too verbose || dbg + = do { (env', msg1) <- liftZonkM $ ctxt1 env + ; (_, msg2) <- liftZonkM $ ctxt2 env' + ; case (msg1, msg2) of + (ExprCtxt{}, StmtErrCtxt (HsDoStmt (DoExpr{})) _) + -> do { let n' = if is_landmark2 then n else n+1 + ; rest <- go dbg n' env' ctxts + ; return (msg2 : rest) } + _ + -> do { let n' = if is_landmark1 then n else n+1 + ; rest <- go dbg n' env' ((is_landmark2, ctxt2) : ctxts) + ; return (msg1 : rest) } + } + | otherwise + = go dbg n env ((is_landmark2, ctxt2) : ctxts) go dbg n env ((is_landmark, ctxt) : ctxts) | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg = do { (env', msg) <- liftZonkM $ ctxt env @@ -1732,6 +1749,14 @@ mkErrCtxt env ctxts | otherwise = go dbg n env ctxts + -- filter_stmt_adj :: [ErrCtxtMsg] -> [ErrCtxtMsg] + -- filter_stmt_adj = concat . map stmtAdj . tails + + -- stmtAdj :: [ErrCtxtMsg] -> [ErrCtxtMsg] + -- stmtAdj (ExprCtxt{} : StmtErrCtxt{} : _ ) = [] + -- stmtAdj (s : _ ) = [s] + -- stmtAdj xs = xs + mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts mAX_CONTEXTS = 3 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/59b20112b403b58e360e0b2296cf9dd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/59b20112b403b58e360e0b2296cf9dd… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T24603] Bisect attempt for ghc js backend
by Serge S. Gulin (＠gulin.serge) 22 Apr '25

22 Apr '25

Serge S. Gulin pushed to branch wip/T24603 at Glasgow Haskell Compiler / GHC Commits: b76fb5e1 by Serge S. Gulin at 2025-04-22T07:31:59+03:00 Bisect attempt for ghc js backend submodule - - - - - 1 changed file: - libraries/Cabal Changes: ===================================== libraries/Cabal ===================================== @@ -1 +1 @@ -Subproject commit 703582f80f6d7f0c914ef4b885affcfc7b7b6ec8 +Subproject commit 24a128e72e51a1d6c2770a95b98035ca048b25f0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b76fb5e15535412dab6217c0bd71796… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b76fb5e15535412dab6217c0bd71796… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] filter expr stmts error msgs
by Apoorv Ingle (＠ani) 22 Apr '25

22 Apr '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 187ef89e by Apoorv Ingle at 2025-04-21T20:18:28-05:00 filter expr stmts error msgs - - - - - 1 changed file: - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1226,14 +1226,14 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) -- | Add a fixed message to the error context. This message should not -- do any tidying. --- no op in generated code +-- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. --- no op in generated code +-- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] @@ -1720,9 +1720,26 @@ mkErrCtxt env ctxts -- then return empty -- just becomes too voluminous -- else go dbg 0 env ctxts = go False 0 env ctxts + where go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] go _ _ _ [] = return [] + go dbg n env ((is_landmark1, ctxt1) : (is_landmark2, ctxt2) : ctxts) + | is_landmark1 || n < mAX_CONTEXTS -- Too verbose || dbg + = do { (env', msg1) <- liftZonkM $ ctxt1 env + ; (env'', msg2) <- liftZonkM $ ctxt2 env' + ; case (msg1, msg2) of + (ExprCtxt{}, StmtErrCtxt (HsDoStmt (DoExpr{})) _) + -> do { let n' = if is_landmark2 then n else n+1 + ; rest <- go dbg n' env' ctxts + ; return (msg2 : rest) } + _ + -> do { let n' = if is_landmark1 then n else n+1 + ; rest <- go dbg n' env' ((is_landmark2, ctxt2) : ctxts) + ; return (msg1 : rest) } + } + | otherwise + = go dbg n env ((is_landmark2, ctxt2) : ctxts) go dbg n env ((is_landmark, ctxt) : ctxts) | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg = do { (env', msg) <- liftZonkM $ ctxt env @@ -1732,6 +1749,14 @@ mkErrCtxt env ctxts | otherwise = go dbg n env ctxts + -- filter_stmt_adj :: [ErrCtxtMsg] -> [ErrCtxtMsg] + -- filter_stmt_adj = concat . map stmtAdj . tails + + -- stmtAdj :: [ErrCtxtMsg] -> [ErrCtxtMsg] + -- stmtAdj (ExprCtxt{} : StmtErrCtxt{} : _ ) = [] + -- stmtAdj (s : _ ) = [s] + -- stmtAdj xs = xs + mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts mAX_CONTEXTS = 3 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/187ef89e6a5536d25173cc1188718da… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/187ef89e6a5536d25173cc1188718da… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] filter expr stmts error msgs
by Apoorv Ingle (＠ani) 22 Apr '25

22 Apr '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 1dad95ad by Apoorv Ingle at 2025-04-21T19:29:47-05:00 filter expr stmts error msgs - - - - - 1 changed file: - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -238,6 +238,7 @@ import Data.IORef import Control.Monad import qualified Data.Map as Map +import Data.List (tails) import GHC.Core.Coercion (isReflCo) @@ -1226,14 +1227,14 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) -- | Add a fixed message to the error context. This message should not -- do any tidying. --- no op in generated code +-- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. --- no op in generated code +-- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] @@ -1719,12 +1720,13 @@ mkErrCtxt env ctxts -- if dbg -- In -dppr-debug style the output -- then return empty -- just becomes too voluminous -- else go dbg 0 env ctxts - = go False 0 env ctxts + = do xs <- go False 0 env ctxts + return $ take mAX_CONTEXTS (filter_stmt_adj xs) where go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] go _ _ _ [] = return [] go dbg n env ((is_landmark, ctxt) : ctxts) - | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg + | is_landmark || n < (mAX_CONTEXTS + 1) -- Too verbose || dbg = do { (env', msg) <- liftZonkM $ ctxt env ; let n' = if is_landmark then n else n+1 ; rest <- go dbg n' env' ctxts @@ -1732,6 +1734,14 @@ mkErrCtxt env ctxts | otherwise = go dbg n env ctxts + filter_stmt_adj :: [ErrCtxtMsg] -> [ErrCtxtMsg] + filter_stmt_adj = concat . map stmtAdj . tails + + stmtAdj :: [ErrCtxtMsg] -> [ErrCtxtMsg] + stmtAdj (ExprCtxt{} : StmtErrCtxt{} : _ ) = [] + stmtAdj (s : _ ) = [s] + stmtAdj xs = xs + mAX_CONTEXTS :: Int -- No more than this number of non-landmark contexts mAX_CONTEXTS = 3 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dad95ad19b6457f4818ed828c85cc6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dad95ad19b6457f4818ed828c85cc6… You're receiving this email because of your account on gitlab.haskell.org.

1 0