- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/T25440] 3 commits: Refactor Handling of Multiple Default Declarations
by Simon Peyton Jones (＠simonpj) 18 Apr '25

18 Apr '25

Simon Peyton Jones pushed to branch wip/T25440 at Glasgow Haskell Compiler / GHC Commits: e0f3ff11 by Patrick at 2025-04-17T04:31:12-04:00 Refactor Handling of Multiple Default Declarations Fixes: #25912, #25914, #25934 Previously, GHC discarded all loaded defaults (tcg_default) when local defaults were encountered during typechecking. According to the exportable-named-default proposal (sections 2.4.2 and 2.4.3), local defaults should be merged into tcg_default, retaining any defaults already present while overriding where necessary. Key Changes: * Introduce DefaultProvenance to track the origin of default declarations (local, imported, or built-in), replacing the original cd_module in ClassDefaults with cd_provenance :: DefaultProvenance. * Rename tcDefaults to tcDefaultDecls, limiting its responsibility to only converting renamed class defaults into ClassDefaults. * Add extendDefaultEnvWithLocalDefaults to merge local defaults into the environment, with proper duplication checks: - Duplicate local defaults for a class trigger an error. - Local defaults override imported or built-in defaults. * Update and add related notes: Note [Builtin class defaults], Note [DefaultProvenance]. * Add regression tests: T25912, T25914, T25934. Thanks sam and simon for the help on this patch. Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - 386f1854 by Teo Camarasu at 2025-04-17T04:31:55-04:00 template-haskell: Remove `addrToByteArrayName` and `addrToByteArray` These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage. Resolves #24782 - - - - - 1a6a4b1e by Simon Peyton Jones at 2025-04-18T17:42:14+01:00 Track rewriter sets more accurately in constraint solving The key change, which fixed #25440, is to call `recordRewriter` in GHC.Tc.Solver.Rewrite.rewrite_exact_fam_app. This missing call meant that we were secretly rewriting a Wanted with a Wanted, but not really noticing; and that led to a very bad error message, as you can see in the ticket. But of course that led me into rabbit hole of other refactoring around the RewriteSet code: * Improve Notes [Wanteds rewrite Wanteds] * Zonk the RewriterSet in `zonkCtEvidence` rather than only in GHC.Tc.Errors. This is tidier anyway (e.g. de-clutters debug output), and helps with the next point. * In GHC.Tc.Solver.Equality.inertsCanDischarge, don't replace a constraint with no rewriters with an equal constraint that has many. See See (CE4) in Note [Combining equalities] * Move zonkRewriterSet and friends from GHC.Tc.Zonk.Type into GHC.Tc.Zonk.TcType, where they properly belong. A handful of tests get better error messages. For some reason T24984 gets 12% less compiler allocation -- good Metric Decrease: T24984 - - - - - 33 changed files: - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/DefaultEnv.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - libraries/template-haskell/changelog.md - + testsuite/tests/default/T25912.hs - + testsuite/tests/default/T25912.stdout - + testsuite/tests/default/T25912_helper.hs - + testsuite/tests/default/T25914.hs - + testsuite/tests/default/T25934.hs - testsuite/tests/default/all.T - testsuite/tests/default/default-fail03.stderr - testsuite/tests/indexed-types/should_fail/T3330c.stderr - testsuite/tests/indexed-types/should_fail/T4174.stderr - testsuite/tests/indexed-types/should_fail/T8227.stderr - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/linters/notes.stdout - testsuite/tests/module/mod58.stderr - testsuite/tests/typecheck/should_fail/T18851.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be011dacff5ef7a07d59ecd52ef5c6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be011dacff5ef7a07d59ecd52ef5c6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] 3 commits: Comments only
by Simon Peyton Jones (＠simonpj) 18 Apr '25

18 Apr '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: b10529e9 by Simon Peyton Jones at 2025-04-18T15:27:53+01:00 Comments only - - - - - e805aa2e by Simon Peyton Jones at 2025-04-18T15:35:54+01:00 Refator GHC.Core.Opt.SetLevels.notWorthFloating I refactored `notWorthFloating` while I was doing something else. I don't think there's a change in behaviour, but if so it's very much a corner case. - - - - - d6c13d5d by Simon Peyton Jones at 2025-04-18T17:16:13+01:00 Always float bottoming expressions to the top ...regardless of floatConsts - - - - - 2 changed files: - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs Changes: ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -482,14 +482,14 @@ Consider this: f :: T Int -> blah f x vs = case x of { MkT y -> let f vs = ...(case y of I# w -> e)...f.. - in f vs + in f vs } Here we can float the (case y ...) out, because y is sure to be evaluated, to give f x vs = case x of { MkT y -> - case y of I# w -> + case y of { I# w -> let f vs = ...(e)...f.. - in f vs + in f vs }} That saves unboxing it every time round the loop. It's important in some DPH stuff where we really want to avoid that repeated unboxing in @@ -614,7 +614,8 @@ lvlMFE env strict_ctxt e@(_, AnnCase {}) = lvlExpr env e -- See Note [Case MFEs] lvlMFE env strict_ctxt ann_expr - | not float_me + | notWorthFloating expr abs_vars + || not float_me || floatTopLvlOnly env && not (isTopLvl dest_lvl) -- Only floating to the top level is allowed. || hasFreeJoin env fvs -- If there is a free join, don't float @@ -623,9 +624,6 @@ lvlMFE env strict_ctxt ann_expr -- We can't let-bind an expression if we don't know -- how it will be represented at runtime. -- See Note [Representation polymorphism invariants] in GHC.Core - || notWorthFloating expr abs_vars - -- Test notWorhtFloating last; - -- See Note [Large free-variable sets] = -- Don't float it out lvlExpr env ann_expr @@ -676,12 +674,11 @@ lvlMFE env strict_ctxt ann_expr is_function = isFunction ann_expr mb_bot_str = exprBotStrictness_maybe expr -- See Note [Bottoming floats] - -- esp Bottoming floats (2) + -- esp Bottoming floats (BF2) expr_ok_for_spec = exprOkForSpeculation expr abs_vars = abstractVars dest_lvl env fvs dest_lvl = destLevel env fvs fvs_ty is_function is_bot_lam - -- NB: is_bot_lam not is_bot; see (3) in - -- Note [Bottoming floats] + -- NB: is_bot_lam not is_bot; see (BF2) in Note [Bottoming floats] -- float_is_new_lam: the floated thing will be a new value lambda -- replacing, say (g (x+4)) by (lvl x). No work is saved, nor is @@ -698,20 +695,22 @@ lvlMFE env strict_ctxt ann_expr -- A decision to float entails let-binding this thing, and we only do -- that if we'll escape a value lambda, or will go to the top level. + -- Never float trivial expressions; + -- notably, save_work might be true of a lone evaluated variable. float_me = saves_work || saves_alloc || is_mk_static -- See Note [Saving work] + is_hnf = exprIsHNF expr saves_work = escapes_value_lam -- (a) - && not (exprIsHNF expr) -- (b) + && not is_hnf -- (b) && not float_is_new_lam -- (c) escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env) - -- See Note [Saving allocation] and Note [Floating to the top] - saves_alloc = isTopLvl dest_lvl - && floatConsts env - && ( not strict_ctxt -- (a) - || exprIsHNF expr -- (b) - || (is_bot_lam && escapes_value_lam)) -- (c) + -- See Note [Floating to the top] + saves_alloc = isTopLvl dest_lvl + && ( (floatConsts env && + (not strict_ctxt || is_hnf)) -- (FT1) and (FT2) + || (is_bot_lam && escapes_value_lam)) -- (FT3) hasFreeJoin :: LevelEnv -> DVarSet -> Bool -- Has a free join point which is not being floated to top level. @@ -726,7 +725,7 @@ hasFreeJoin env fvs The key idea in let-floating is to * float a redex out of a (value) lambda Doing so can save an unbounded amount of work. -But see also Note [Saving allocation]. +But see also Note [Floating to the top]. So we definitely float an expression out if (a) It will escape a value lambda (escapes_value_lam) @@ -771,10 +770,12 @@ Wrinkles: we have saved nothing: one pair will still be allocated for each call of `f`. Hence the (not float_is_new_lam) in saves_work. -Note [Saving allocation] -~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Floating to the top] +~~~~~~~~~~~~~~~~~~~~~~~~~~ Even if `saves_work` is false, we we may want to float even cheap/HNF -expressions out of value lambdas, for several reasons: +expressions out of value lambdas. Data suggests, however, that it is better +/only/ to do so, /if/ they can go to top level. If the expression goes to top +level we don't pay the cost of allocating cold-path thunks described in (SW2). * Doing so may save allocation. Consider f = \x. .. (\y.e) ... @@ -782,6 +783,11 @@ expressions out of value lambdas, for several reasons: (assuming e does not mention x). An example where this really makes a difference is simplrun009. +* In principle this would be true even if the (\y.e) didn't go to top level; but + in practice we only float a HNF if it goes all way to the top. We don't pay + /any/ allocation cost for a top-level floated expression; it just becomes + static data. + * It may allow SpecContr to fire on functions. Consider f = \x. ....(f (\y.e)).... After floating we get @@ -793,21 +799,7 @@ expressions out of value lambdas, for several reasons: a big difference for string literals and bottoming expressions: see Note [Floating to the top] -Data suggests, however, that it is better /only/ to float HNFS, /if/ they can go -to top level. See (SW2) of Note [Saving work]. If the expression goes to top -level we don't pay the cost of allocating cold-path thunks described in (SW2). - -Hence `isTopLvl dest_lvl` in `saves_alloc`. - -Note [Floating to the top] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even though Note [Saving allocation] suggests that we should not, in -general, float HNFs, the balance change if it goes to the top: - -* We don't pay an allocation cost for the floated expression; it - just becomes static data. - -* Floating string literal is valuable -- no point in duplicating the +* Floating string literals is valuable -- no point in duplicating the at each call site! * Floating bottoming expressions is valuable: they are always cold @@ -815,32 +807,32 @@ general, float HNFs, the balance change if it goes to the top: can be quite big, inhibiting inlining. See Note [Bottoming floats] So we float an expression to the top if: - (a) the context is lazy (so we get allocation), or - (b) the expression is a HNF (so we get allocation), or - (c) the expression is bottoming and floating would escape a - value lambda (NB: if the expression itself is a lambda, (b) - will apply; so this case only catches bottoming thunks) + (FT1) the context is lazy (so we get allocation), or + (FT2) the expression is a HNF (so we get allocation), or + (FT3) the expression is bottoming and floating would escape a + value lambda (NB: if the expression itself is a lambda, (b) + will apply; so this case only catches bottoming thunks) Examples: -* (a) Strict. Case scrutinee +* (FT1) Strict. Case scrutinee f = case g True of .... Don't float (g True) to top level; then we have the admin of a top-level thunk to worry about, with zero gain. -* (a) Strict. Case alternative +* (FT1) Strict. Case alternative h = case y of True -> g True False -> False Don't float (g True) to the top level -* (b) HNF +* (FT2) HNF f = case y of True -> p:q False -> blah We may as well float the (p:q) so it becomes a static data structure. -* (c) Bottoming expressions; see also Note [Bottoming floats] +* (FT3) Bottoming expressions; see also Note [Bottoming floats] f x = case x of 0 -> error <big thing> _ -> x+1 @@ -853,7 +845,7 @@ Examples: 'foo' anyway. So float bottoming things only if they escape a lambda. -* Arguments +* (FT4) Arguments t = f (g True) Prior to Apr 22 we didn't float (g True) to the top if f was strict. But (a) this only affected CAFs, because if it escapes a value lambda @@ -868,28 +860,6 @@ early loses opportunities for RULES which (needless to say) are important in some nofib programs (gcd is an example). [SPJ note: I think this is obsolete; the flag seems always on.] -Note [Large free-variable sets] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #24471 we had something like - x1 = I# 1 - ... - x1000 = I# 1000 - foo = f x1 (f x2 (f x3 ....)) -So every sub-expression in `foo` has lots and lots of free variables. But -none of these sub-expressions float anywhere; the entire float-out pass is a -no-op. - -In lvlMFE, we want to find out quickly if the MFE is not-floatable; that is -the common case. In #24471 it turned out that we were testing `abs_vars` (a -relatively complicated calculation that takes at least O(n-free-vars) time to -compute) for every sub-expression. - -Better instead to test `float_me` early. That still involves looking at -dest_lvl, which means looking at every free variable, but the constant factor -is a lot better. - -ToDo: find a way to fix the bad asymptotic complexity. - Note [Floating join point bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Mostly we don't float join points at all -- we want them to /stay/ join points. @@ -1053,30 +1023,36 @@ we'd like to float the call to error, to get But, as ever, we need to be careful: -(1) We want to float a bottoming +(BF1) We want to float a bottoming expression even if it has free variables: f = \x. g (let v = h x in error ("urk" ++ v)) Then we'd like to abstract over 'x', and float the whole arg of g: lvl = \x. let v = h x in error ("urk" ++ v) f = \x. g (lvl x) - To achieve this we pass is_bot to destLevel - -(2) We do not do this for lambdas that return - bottom. Instead we treat the /body/ of such a function specially, - via point (1). For example: + To achieve this we pass `is_bot` to destLevel + +(BF2) We do the same for /lambdas/ that return bottom. + Suppose the original lambda had /no/ free vars: + f = \x. ....(\y z. error (y++z))... + then we'd like to float that whole lambda + lvl = \y z. error (y++z) + f = \x. ....lvl.... + If we just floated its bottom-valued body, we might abstract the arguments in + the "wrong" order and end up with this bad result + lvl = \z y. error (y++z) + f = \x. ....(\y z. lvl z y).... + + If the lambda does have free vars, this will happen: f = \x. ....(\y z. if x then error y else error z).... - If we float the whole lambda thus + We float the whole lambda thus lvl = \x. \y z. if x then error y else error z f = \x. ...(lvl x)... - we may well end up eta-expanding that PAP to + And we may well end up eta-expanding that PAP to + lvl = \x. \y z. if b then error y else error z f = \x. ...(\y z. lvl x y z)... + so we get a (small) closure. So be it. - ===> - lvl = \x z y. if b then error y else error z - f = \x. ...(\y z. lvl x z y)... - (There is no guarantee that we'll choose the perfect argument order.) - -(3) If we have a /binding/ that returns bottom, we want to float it to top +(BF3) If we have a /binding/ that returns bottom, we want to float it to top level, even if it has free vars (point (1)), and even it has lambdas. Example: ... let { v = \y. error (show x ++ show y) } in ... @@ -1092,7 +1068,6 @@ But, as ever, we need to be careful: join points (#24768), and floating to the top would abstract over those join points, which we should never do. - See Maessen's paper 1999 "Bottom extraction: factoring error handling out of functional programs" (unpublished I think). @@ -1135,7 +1110,6 @@ float the case (as advocated here) we won't float the (build ...y..) either, so fusion will happen. It can be a big effect, esp in some artificial benchmarks (e.g. integer, queens), but there is no perfect answer. - -} annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig, CprSig) -> Id @@ -1152,69 +1126,124 @@ annotateBotStr id n_extra mb_bot_str = id notWorthFloating :: CoreExpr -> [Var] -> Bool --- Returns True if the expression would be replaced by --- something bigger than it is now. For example: --- abs_vars = tvars only: return True if e is trivial, --- but False for anything bigger --- abs_vars = [x] (an Id): return True for trivial, or an application (f x) --- but False for (f x x) --- --- One big goal is that floating should be idempotent. Eg if --- we replace e with (lvl79 x y) and then run FloatOut again, don't want --- to replace (lvl79 x y) with (lvl83 x y)! - +-- See Note [notWorthFloating] notWorthFloating e abs_vars - = go e (count isId abs_vars) + = go e 0 where - go (Var {}) n = n >= 0 - go (Lit lit) n = assert (n==0) $ - litIsTrivial lit -- Note [Floating literals] - go (Type {}) _ = True - go (Coercion {}) _ = True + n_abs_vars = count isId abs_vars -- See (NWF5) + + go :: CoreExpr -> Int -> Bool + -- (go e n) return True if (e x1 .. xn) is not worth floating + -- where `e` has n trivial value arguments x1..xn + -- See (NWF4) + go (Lit lit) n = assert (n==0) $ + litIsTrivial lit -- See (NWF1) + go (Type {}) _ = True + go (Tick t e) n = not (tickishIsCode t) && go e n + go (Cast e _) n = n==0 || go e n -- See (NWF3) + go (Coercion {}) _ = True go (App e arg) n - -- See Note [Floating applications to coercions] - | not (isRuntimeArg arg) = go e n - | n==0 = False - | exprIsTrivial arg = go e (n-1) -- NB: exprIsTrivial arg = go arg 0 - | otherwise = False - go (Tick t e) n = not (tickishIsCode t) && go e n - go (Cast e _) n = go e n - go (Case e b _ as) n + | Type {} <- arg = go e n -- Just types, not coercions (NWF2) + | exprIsTrivial arg = go e (n+1) + | otherwise = False -- (f non-triv) is worth floating + + go (Case e b _ as) _ + -- Do not float the `case` part of trivial cases (NWF3) + -- We'll have a look at the RHS when we get there | null as - = go e n -- See Note [Empty case is trivial] - | Just rhs <- isUnsafeEqualityCase e b as - = go rhs n -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce - go _ _ = False + = True -- See Note [Empty case is trivial] + | Just {} <- isUnsafeEqualityCase e b as + = True -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce + | otherwise + = False -{- -Note [Floating literals] -~~~~~~~~~~~~~~~~~~~~~~~~ -It's important to float Integer literals, so that they get shared, -rather than being allocated every time round the loop. -Hence the litIsTrivial. + go (Var _) n + | n==0 = True -- Naked variable + | n <= n_abs_vars = True -- (f a b c) is not worth floating if + | otherwise = False -- a,b,c are all abstracted; see (NWF5) -Ditto literal strings (LitString), which we'd like to float to top -level, which is now possible. + go _ _ = False -- Let etc is worth floating -Note [Floating applications to coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don’t float out variables applied only to type arguments, since the -extra binding would be pointless: type arguments are completely erased. -But *coercion* arguments aren’t (see Note [Coercion tokens] in -"GHC.CoreToStg" and Note [inlineBoringOk] in"GHC.Core.Unfold"), -so we still want to float out variables applied only to -coercion arguments. +{- Note [notWorthFloating] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +`notWorthFloating` returns True if the expression would be replaced by something +bigger than it is now. One big goal is that floating should be idempotent. Eg +if we replace e with (lvl79 x y) and then run FloatOut again, don't want to +replace (lvl79 x y) with (lvl83 x y)! +For example: + abs_vars = tvars only: return True if e is trivial, + but False for anything bigger + abs_vars = [x] (an Id): return True for trivial, or an application (f x) + but False for (f x x) + +(NWF1) It's important to float Integer literals, so that they get shared, rather + than being allocated every time round the loop. Hence the litIsTrivial. + + Ditto literal strings (LitString), which we'd like to float to top + level, which is now possible. + +(NWF2) We don’t float out variables applied only to type arguments, since the + extra binding would be pointless: type arguments are completely erased. + But *coercion* arguments aren’t (see Note [Coercion tokens] in + "GHC.CoreToStg" and Note [inlineBoringOk] in"GHC.Core.Unfold"), + so we still want to float out variables applied only to + coercion arguments. + +(NWF3) Some expressions have trivial wrappers: + - Casts (e |> co) + - Unary-class applications: + - Dictionary applications (MkC meth) + - Class-op applictions (op dict) + - Case of empty alts + - Unsafe-equality case + In all these cases we say "not worth floating", and we do so /regardless/ + of the wrapped expression. The SetLevels stuff may subsequently float the + components of the expression. + + Example: is it worth floating (f x |> co)? No! If we did we'd get + lvl = f x |> co + ...lvl.... + Then we'd do cast worker/wrapper and end up with. + lvl' = f x + ...(lvl' |> co)... + Silly! Better not to float it in the first place. If we say "no" here, + we'll subsequently say "yes" for (f x) and get + lvl = f x + ....(lvl |> co)... + which is what we want. In short: don't float trivial wrappers. + +(NWF4) The only non-trivial expression that we say "not worth floating" for + is an application + f x y z + where the number of value arguments is <= the number of abstracted Ids. + This is what makes floating idempotent. Hence counting the number of + value arguments in `go` + +(NWF5) In #24471 we had something like + x1 = I# 1 + ... + x1000 = I# 1000 + foo = f x1 (f x2 (f x3 ....)) + So every sub-expression in `foo` has lots and lots of free variables. But + none of these sub-expressions float anywhere; the entire float-out pass is a + no-op. -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ + So `notWorthFloating` tries to avoid evaluating `n_abs_vars`, in cases where + it obviously /is/ worth floating. (In #24471 it turned out that we were + testing `abs_vars` (a relatively complicated calculation that takes at least + O(n-free-vars) time to compute) for every sub-expression.) -The binding stuff works for top level too. + Hence testing `n_abs_vars only` at the very end. -} +{- ********************************************************************* +* * + Bindings + This binding stuff works for top level too. +* * +********************************************************************* -} + lvlBind :: LevelEnv -> CoreBindWithFVs -> LvlM (LevelledBind, LevelEnv) @@ -1261,7 +1290,7 @@ lvlBind env (AnnNonRec bndr rhs) -- is_bot_lam: looks like (\xy. bot), maybe zero lams -- NB: not isBottomThunk! -- NB: not is_join: don't send bottoming join points to the top. - -- See Note [Bottoming floats] point (3) + -- See Note [Bottoming floats] (BF3) is_top_bindable = exprIsTopLevelBindable deann_rhs bndr_ty n_extra = count isId abs_vars @@ -1552,9 +1581,8 @@ destLevel env fvs fvs_ty is_function is_bot -- See Note [Floating join point bindings] = tOP_LEVEL - | is_bot -- Send bottoming bindings to the top - = as_far_as_poss -- regardless; see Note [Bottoming floats] - -- Esp Bottoming floats (1) and (3) + | is_bot -- Send bottoming bindings to the top regardless; + = as_far_as_poss -- see (BF1) and (BF2) in Note [Bottoming floats] | Just n_args <- floatLams env , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case @@ -1568,8 +1596,13 @@ destLevel env fvs fvs_ty is_function is_bot max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the -- tyvars will be abstracted + -- as_far_as_poss: destination level depends only on the free Ids (more + -- precisely, free CoVars) of the /type/, not the free Ids of the /term/. + -- Why worry about the free CoVars? See Note [Floating and kind casts] + -- + -- There may be free Ids in the term, but then we'll just + -- lambda-abstract over them as_far_as_poss = maxFvLevel' isId env fvs_ty - -- See Note [Floating and kind casts] {- Note [Floating and kind casts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1732,10 +1765,9 @@ maxFvLevel max_me env var_set -- It's OK to use a non-deterministic fold here because maxIn commutes. maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level --- Same but for TyCoVarSet +-- Precisely the same as `maxFvLevel` but for TyCoVarSet rather than DVarSet maxFvLevel' max_me env var_set = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set - -- It's OK to use a non-deterministic fold here because maxIn commutes. maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -801,9 +801,9 @@ makeTrivial env top_lvl dmd occ_fs expr = return (emptyLetFloats, expr) | not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise - = return (emptyLetFloats, expr) -- See Note [Cannot trivialise] + = return (emptyLetFloats, expr) -- See Note [Cannot trivialise] - | otherwise -- 'expr' is not of form (Cast e co) + | otherwise = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr ; uniq <- getUniqueM ; let name = mkSystemVarName uniq occ_fs View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bc27b6c9b536a8200cd2b8750e4744… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bc27b6c9b536a8200cd2b8750e4744… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25975] Fix bytecode generation for `tagToEnum# <LITERAL>`
by Matthew Craven (＠clyring) 18 Apr '25

18 Apr '25

Matthew Craven pushed to branch wip/T25975 at Glasgow Haskell Compiler / GHC Commits: 6cb3e990 by Matthew Craven at 2025-04-18T08:31:11-04:00 Fix bytecode generation for `tagToEnum# <LITERAL>` Fixes #25975. - - - - - 4 changed files: - compiler/GHC/StgToByteCode.hs - + testsuite/tests/bytecode/T25975.hs - + testsuite/tests/bytecode/T25975.stdout - testsuite/tests/bytecode/all.T Changes: ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -1801,10 +1801,14 @@ maybe_getCCallReturnRep fn_ty _ -> pprPanic "maybe_getCCallReturn: can't handle:" (pprType fn_ty) -maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name]) +maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (StgArg, [Name]) -- Detect and extract relevant info for the tagToEnum kludge. -maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t) +maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) args t) + | [v] <- args = Just (v, extract_constr_Names t) + | otherwise + = pprPanic "StgToByteCode: tagToEnum#" + $ text "Expected exactly one arg, but actual args are:" <+> ppr args where extract_constr_Names ty | rep_ty <- unwrapType ty @@ -1851,13 +1855,13 @@ implement_tagToId :: StackDepth -> Sequel -> BCEnv - -> Id + -> StgArg -> [Name] -> BcM BCInstrList -- See Note [Implementing tagToEnum#] implement_tagToId d s p arg names = assert (notNull names) $ - do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg) + do (push_arg, arg_bytes) <- pushAtom d p arg labels <- getLabelsBc (strictGenericLength names) label_fail <- getLabelBc label_exit <- getLabelBc ===================================== testsuite/tests/bytecode/T25975.hs ===================================== @@ -0,0 +1,27 @@ +-- Tests bytecode generation for tagToEnum# applied to literals +{-# LANGUAGE MagicHash #-} +module Main (main) where + +import GHC.Exts + +f1 :: Int# -> Bool +{-# OPAQUE f1 #-} +f1 v = case v of + 4# -> tagToEnum# v + _ -> False + +f2 :: Int# -> Bool +{-# OPAQUE f2 #-} +f2 v = case v of + 5# -> tagToEnum# 6# + _ -> True + +f3 :: Ordering +f3 = tagToEnum# (noinline runRW# (\_ -> 1#)) + + +main :: IO () +main = do + print $ f1 2# + print $ f2 3# + print f3 ===================================== testsuite/tests/bytecode/T25975.stdout ===================================== @@ -0,0 +1,3 @@ +False +True +EQ ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -1,3 +1,7 @@ ghci_dump_bcos = [only_ways(['ghci']), extra_run_opts('-dno-typeable-binds -dsuppress-uniques -ddump-bcos')] test('T23068', ghci_dump_bcos + [filter_stdout_lines(r'.*bitmap: .*')], ghci_script, ['T23068.script']) + +test('T25975', extra_ways(ghci_ways), compile_and_run, + # Some of the examples work more robustly with these flags + ['-fno-break-points -fno-full-laziness']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6cb3e990906148813038a3158076746… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6cb3e990906148813038a3158076746… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T25975
by Matthew Craven (＠clyring) 18 Apr '25

18 Apr '25

Matthew Craven pushed new branch wip/T25975 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T25975 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25440] Wibbles
by Simon Peyton Jones (＠simonpj) 18 Apr '25

18 Apr '25

Simon Peyton Jones pushed to branch wip/T25440 at Glasgow Haskell Compiler / GHC Commits: be011dac by Simon Peyton Jones at 2025-04-18T13:12:23+01:00 Wibbles - - - - - 12 changed files: - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - testsuite/tests/indexed-types/should_fail/T3330c.stderr - testsuite/tests/indexed-types/should_fail/T4174.stderr - testsuite/tests/indexed-types/should_fail/T8227.stderr - testsuite/tests/typecheck/should_fail/T18851.stderr Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -466,13 +466,12 @@ mkErrorItem ct = do { let loc = ctLoc ct flav = ctFlavour ct - ; (suppress, m_evdest) <- case ctEvidence ct of - -- For this `suppress` stuff - -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint - CtGiven {} -> return (False, Nothing) - CtWanted (WantedCt { ctev_rewriters = rewriters, ctev_dest = dest }) - -> do { rewriters' <- zonkRewriterSet rewriters - ; return (not (isEmptyRewriterSet rewriters'), Just dest) } + (suppress, m_evdest) = case ctEvidence ct of + -- For this `suppress` stuff + -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint + CtGiven {} -> (False, Nothing) + CtWanted (WantedCt { ctev_rewriters = rws, ctev_dest = dest }) + -> (not (isEmptyRewriterSet rws), Just dest) ; let m_reason = case ct of CIrredCan (IrredCt { ir_reason = reason }) -> Just reason @@ -503,7 +502,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics , text "tidy_errs =" <+> ppr tidy_errs ]) -- Catch an awkward (and probably rare) case in which /all/ errors are - -- suppressed: see Wrinkle (WRW2) in Note [Prioritise Wanteds with empty + -- suppressed: see Wrinkle (PER2) in Note [Prioritise Wanteds with empty -- RewriterSet] in GHC.Tc.Types.Constraint. -- -- Unless we are sure that an error will be reported some other way ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -1081,9 +1081,9 @@ disambigProposalSequences orig_wanteds wanteds proposalSequences allConsistent ; successes <- fmap catMaybes $ nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) $ mapM firstSuccess proposalSequences - ; traceTcS "disambigProposalSequences" (vcat [ ppr wanteds - , ppr proposalSequences - , ppr successes ]) + ; traceTcS "disambigProposalSequences {" (vcat [ ppr wanteds + , ppr proposalSequences + , ppr successes ]) -- Step (4) in Note [How type-class constraints are defaulted] ; case successes of success@(tvs, subst) : rest ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -2077,11 +2077,15 @@ Wrinkles: that `kw`. (EIK2a) We must later indeed unify if/when the kind-level wanted, `kw` gets - solved. This is done in kickOutAfterFillingCoercionHole, which kicks out + solved. This is done in `kickOutAfterFillingCoercionHole`, which kicks out all equalities whose RHS mentions the filled-in coercion hole. Note that it looks for type family equalities, too, because of the use of unifyTest in canEqTyVarFunEq. + To do this, we slightly-hackily use the `ctev_rewriters` field of the inert, + which records that `w` has been rewritten by `kw`. + See (WRW3) in Note [Wanteds reewrite Wanteds] in GHC.Tc.Types.Constraint. + (EIK2b) What if the RHS mentions /other/ coercion holes? How can that happen? The main way is like this. Assume F :: forall k. k -> Type [W] kw : k ~ Type @@ -2615,6 +2619,7 @@ But it's not so simple: error message that we can solve (F a ~ a Int) arising from F a ~ F a Better to hang on to `g1`, in preference to `g2`. + See (WRW1) in Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. -} tryInertEqs :: EqCt -> SolverStage () ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -150,7 +150,6 @@ import qualified GHC.Tc.Utils.Env as TcM , topIdLvl ) import GHC.Tc.Zonk.Monad ( ZonkM ) import qualified GHC.Tc.Zonk.TcType as TcM -import qualified GHC.Tc.Zonk.Type as TcM import GHC.Driver.DynFlags @@ -489,7 +488,7 @@ kickOutAfterFillingCoercionHole hole kick_out ics@(IC { inert_irreds = irreds }) = -- We only care about irreds here, because any constraint blocked -- by a coercion hole is an irred. See wrinkle (EIK2a) in - -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical + -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality (irreds_to_kick, ics { inert_irreds = irreds_to_keep }) where (irreds_to_kick, irreds_to_keep) = partitionBag kick_ct irreds @@ -1457,8 +1456,8 @@ emitWork cts -- c1 is rewritten by another, c2. When c2 gets solved, -- c1 has no rewriters, and can be prioritised; see -- Note [Prioritise Wanteds with empty RewriterSet] - -- in GHC.Tc.Types.Constraint wrinkle (WRW1) - ; cts <- wrapTcS $ mapBagM TcM.zonkCtRewriterSet cts + -- in GHC.Tc.Types.Constraint wrinkle (PER1) + ; cts <- liftZonkTcS $ mapBagM TcM.zonkCtRewriterSet cts ; updWorkListTcS (extendWorkListCts cts) } emitImplication :: Implication -> TcS () @@ -2252,7 +2251,7 @@ wrapUnifierX ev role do_unifications ; wrapTcS $ do { defer_ref <- TcM.newTcRef emptyBag ; unified_ref <- TcM.newTcRef [] - ; rewriters <- TcM.zonkRewriterSet (ctEvRewriters ev) + ; rewriters <- TcM.liftZonkM (TcM.zonkRewriterSet (ctEvRewriters ev)) ; let env = UE { u_role = role , u_rewriters = rewriters , u_loc = ctEvLoc ev ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -240,7 +240,7 @@ instance Outputable DictCt where {- Note [Canonical equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An EqCt is a canonical equality constraint, one that can live in the inert set, -and that can be used to rewrite other constrtaints. It satisfies these invariants: +and that can be used to rewrite other constraints. It satisfies these invariants: * (TyEq:OC) lhs does not occur in rhs (occurs check) Note [EqCt occurs check] * (TyEq:F) rhs has no foralls @@ -2444,19 +2444,29 @@ We thus want Wanteds to rewrite Wanteds in order to accept more programs, but we don't want Wanteds to rewrite Wanteds because doing so can create inscrutable error messages. To solve this dilemma: -* We allow Wanteds to rewrite Wanteds, but... +* We allow Wanteds to rewrite Wanteds, but each Wanted tracks the set of Wanteds + it has been rewritten by, in its RewriterSet, stored in the ctev_rewriters + field of the CtWanted constructor of CtEvidence. (Only Wanteds have + RewriterSets.) -* Each Wanted tracks the set of Wanteds it has been rewritten by, in its - RewriterSet, stored in the ctev_rewriters field of the CtWanted - constructor of CtEvidence. (Only Wanteds have RewriterSets.) +* A RewriterSet is just a set of unfilled CoercionHoles. This is sufficient + because only equalities (evidenced by coercion holes) are used for rewriting; + other (dictionary) constraints cannot ever rewrite. + +* The rewriter (in e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks and returns a RewriterSet, + consisting of the evidence (a CoercionHole) for any Wanted equalities used in + rewriting. + +* Then GHC.Tc.Solver.Solve.rewriteEvidence and GHC.Tc.Solver.Equality.rewriteEqEvidence + add this RewriterSet to the rewritten constraint's rewriter set. * In error reporting, we simply suppress any errors that have been rewritten by /unsolved/ wanteds. This suppression happens in GHC.Tc.Errors.mkErrorItem, - which uses GHC.Tc.Zonk.Type.zonkRewriterSet to look through any filled + which uses `GHC.Tc.Zonk.Type.zonkRewriterSet` to look through any filled coercion holes. The idea is that we wish to report the "root cause" -- the error that rewrote all the others. -* We prioritise Wanteds that have an empty RewriterSet: +* In error reporting, we prioritise Wanteds that have an empty RewriterSet: see Note [Prioritise Wanteds with empty RewriterSet]. Let's continue our first example above: @@ -2471,19 +2481,30 @@ Because Wanteds can rewrite Wanteds, w1 will rewrite w2, yielding The {w1} in the second line of output is the RewriterSet of w1. -A RewriterSet is just a set of unfilled CoercionHoles. This is sufficient -because only equalities (evidenced by coercion holes) are used for rewriting; -other (dictionary) constraints cannot ever rewrite. The rewriter (in -e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks and returns a RewriterSet, -consisting of the evidence (a CoercionHole) for any Wanted equalities used in -rewriting. Then GHC.Tc.Solver.Solve.rewriteEvidence and -GHC.Tc.Solver.Equality.rewriteEqEvidence add this RewriterSet to the rewritten -constraint's rewriter set. +Wrinkles: + +(WRW1) When we find a constraint identical to one already in the inert set, + we solve one from the other. Other things being equal, keep the one + that has fewer (better still no) rewriters. + See (CE4) in Note [Combining equalities] in GHC.Tc.Solver.Equality. + + To this accurately we should use `zonkRewriterSet` during canonicalisation, + to eliminate rewriters that have now been solved. Currently we only do so + during error reporting; but perhaps we should change that. + +(WRW2) When zonk a constraint (with `zonkCt` and `zonkCtEvidence`) we take + the opportunity to zonk its `RewriterSet, which eliminates solved ones`. + This doesn't guarantee that rewriter sets are always up to date -- see + (WRW1) -- but it helps, and it de-clutters debug output. + +(WRW3) We use the rewriter set for a slightly different purpose, in (EIK2) + of Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality. + This is a bit of a hack. Note [Prioritise Wanteds with empty RewriterSet] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When extending the WorkList, in GHC.Tc.Solver.InertSet.extendWorkListEq, -we priorities constraints that have no rewriters. Here's why. +we prioritise constraints that have no rewriters. Here's why. Consider this, which came up in T22793: inert: {} @@ -2527,11 +2548,11 @@ GHC.Tc.Solver.InertSet.extendWorkListEq, and extendWorkListEqs. Wrinkles -(WRW1) Before checking for an empty RewriterSet, we zonk the RewriterSet, +(PER1) Before checking for an empty RewriterSet, we zonk the RewriterSet, because some of those CoercionHoles may have been filled in since we last looked: see GHC.Tc.Solver.Monad.emitWork. -(WRW2) Despite the prioritisation, it is hard to be /certain/ that we can't end up +(PER2) Despite the prioritisation, it is hard to be /certain/ that we can't end up in a situation where all of the Wanteds have rewritten each other. In order to report /some/ error in this case, we simply report all the Wanteds. The user will get a perhaps-confusing error message, but they've ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -49,7 +49,6 @@ module GHC.Tc.Utils.TcMType ( newCoercionHole, newCoercionHoleO, newVanillaCoercionHole, fillCoercionHole, isFilledCoercionHole, - unpackCoercionHole, unpackCoercionHole_maybe, checkCoercionHole, newImplication, @@ -115,7 +114,6 @@ import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin ) import GHC.Tc.Utils.Monad -- TcType, amongst others import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types -import GHC.Tc.Zonk.Type import GHC.Tc.Zonk.TcType import GHC.Builtin.Names @@ -1583,7 +1581,7 @@ collect_cand_qtvs_co orig_ty cur_lvl bound = go_co go_co dv (SubCo co) = go_co dv co go_co dv (HoleCo hole) - = do m_co <- unpackCoercionHole_maybe hole + = do m_co <- liftZonkM (unpackCoercionHole_maybe hole) case m_co of Just co -> go_co dv co Nothing -> go_cv dv (coHoleCoVar hole) ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} + {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1996-1998 @@ -36,6 +38,13 @@ module GHC.Tc.Zonk.TcType -- ** Zonking constraints , zonkCt, zonkWC, zonkSimples, zonkImplication + -- * Rewriter sets + , zonkRewriterSet, zonkCtRewriterSet, zonkCtEvRewriterSet + + -- * Coercion holes + , isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe + + -- * Tidying , tcInitTidyEnv, tcInitOpenTidyEnv , tidyCt, tidyEvVar, tidyDelayedError @@ -81,7 +90,7 @@ import GHC.Core.Coercion import GHC.Core.Predicate import GHC.Utils.Constants -import GHC.Utils.Outputable +import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc import GHC.Utils.Monad ( mapAccumLM ) import GHC.Utils.Panic @@ -89,6 +98,9 @@ import GHC.Utils.Panic import GHC.Data.Bag import GHC.Data.Pair +import Data.Semigroup +import Data.Maybe + {- ********************************************************************* * * Writing to metavariables @@ -366,8 +378,8 @@ checkCoercionHole cv co ; return $ assertPpr (ok cv_ty) (text "Bad coercion hole" <+> - ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role - , ppr cv_ty ]) + ppr cv Outputable.<> colon + <+> vcat [ ppr t1, ppr t2, ppr role, ppr cv_ty ]) co } | otherwise = return co @@ -494,9 +506,15 @@ zonkCt ct ; return (mkNonCanonical fl') } zonkCtEvidence :: CtEvidence -> ZonkM CtEvidence -zonkCtEvidence ctev - = do { pred' <- zonkTcType (ctEvPred ctev) - ; return (setCtEvPredType ctev pred') } +-- Zonks the ctev_pred and the ctev_rewriters; but not ctev_evar +-- For ctev_rewriters, see (WRW2) in Note [Wanteds rewrite Wanteds] +zonkCtEvidence (CtGiven (GivenCt { ctev_pred = pred, ctev_evar = var, ctev_loc = loc })) + = do { pred' <- zonkTcType pred + ; return (CtGiven (GivenCt { ctev_pred = pred', ctev_evar = var, ctev_loc = loc })) } +zonkCtEvidence (CtWanted wanted@(WantedCt { ctev_pred = pred, ctev_rewriters = rws })) + = do { pred' <- zonkTcType pred + ; rws' <- zonkRewriterSet rws + ; return (CtWanted (wanted { ctev_pred = pred', ctev_rewriters = rws' })) } zonkSkolemInfo :: SkolemInfo -> ZonkM SkolemInfo zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk @@ -530,6 +548,103 @@ win. But c.f Note [Sharing when zonking to Type] in GHC.Tc.Zonk.Type. +%************************************************************************ +%* * + Zonking rewriter sets +* * +************************************************************************ +-} + +zonkCtRewriterSet :: Ct -> ZonkM Ct +zonkCtRewriterSet ct + | isGivenCt ct + = return ct + | otherwise + = case ct of + CEqCan eq@(EqCt { eq_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CEqCan (eq { eq_ev = ev' })) } + CIrredCan ir@(IrredCt { ir_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CIrredCan (ir { ir_ev = ev' })) } + CDictCan di@(DictCt { di_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CDictCan (di { di_ev = ev' })) } + CQuantCan {} -> return ct + CNonCanonical ev -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CNonCanonical ev') } + +zonkCtEvRewriterSet :: CtEvidence -> ZonkM CtEvidence +zonkCtEvRewriterSet ev@(CtGiven {}) + = return ev +zonkCtEvRewriterSet ev@(CtWanted wtd) + = do { rewriters' <- zonkRewriterSet (ctEvRewriters ev) + ; return (CtWanted $ setWantedCtEvRewriters wtd rewriters') } + +-- | Check whether any coercion hole in a RewriterSet is still unsolved. +-- Does this by recursively looking through filled coercion holes until +-- one is found that is not yet filled in, at which point this aborts. +zonkRewriterSet :: RewriterSet -> ZonkM RewriterSet +zonkRewriterSet (RewriterSet set) + = nonDetStrictFoldUniqSet go (return emptyRewriterSet) set + -- this does not introduce non-determinism, because the only + -- monadic action is to read, and the combining function is + -- commutative + where + go :: CoercionHole -> ZonkM RewriterSet -> ZonkM RewriterSet + go hole m_acc = unionRewriterSet <$> check_hole hole <*> m_acc + + check_hole :: CoercionHole -> ZonkM RewriterSet + check_hole hole = do { m_co <- unpackCoercionHole_maybe hole + ; case m_co of + Nothing -> return (unitRewriterSet hole) + Just co -> unUCHM (check_co co) } + + check_ty :: Type -> UnfilledCoercionHoleMonoid + check_co :: Coercion -> UnfilledCoercionHoleMonoid + (check_ty, _, check_co, _) = foldTyCo folder () + + folder :: TyCoFolder () UnfilledCoercionHoleMonoid + folder = TyCoFolder { tcf_view = noView + , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv) + , tcf_covar = \ _ cv -> check_ty (varType cv) + , tcf_hole = \ _ -> UCHM . check_hole + , tcf_tycobinder = \ _ _ _ -> () } + +newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: ZonkM RewriterSet } + +instance Semigroup UnfilledCoercionHoleMonoid where + UCHM l <> UCHM r = UCHM (unionRewriterSet <$> l <*> r) + +instance Monoid UnfilledCoercionHoleMonoid where + mempty = UCHM (return emptyRewriterSet) + + +{- +************************************************************************ +* * + Checking for coercion holes +* * +************************************************************************ +-} + +-- | Is a coercion hole filled in? +isFilledCoercionHole :: CoercionHole -> ZonkM Bool +isFilledCoercionHole (CoercionHole { ch_ref = ref }) + = isJust <$> readTcRef ref + +-- | Retrieve the contents of a coercion hole. Panics if the hole +-- is unfilled +unpackCoercionHole :: CoercionHole -> ZonkM Coercion +unpackCoercionHole hole + = do { contents <- unpackCoercionHole_maybe hole + ; case contents of + Just co -> return co + Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } + +-- | Retrieve the contents of a coercion hole, if it is filled +unpackCoercionHole_maybe :: CoercionHole -> ZonkM (Maybe Coercion) +unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref + + +{- %************************************************************************ %* * Tidying ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -28,12 +28,6 @@ module GHC.Tc.Zonk.Type ( -- ** 'ZonkEnv', and the 'ZonkT' and 'ZonkBndrT' monad transformers module GHC.Tc.Zonk.Env, - -- * Coercion holes - isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe, - - -- * Rewriter sets - zonkRewriterSet, zonkCtRewriterSet, zonkCtEvRewriterSet, - -- * Tidying tcInitTidyEnv, tcInitOpenTidyEnv, @@ -55,7 +49,6 @@ import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr ) -import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Errors.Types import GHC.Tc.Zonk.Env @@ -88,7 +81,6 @@ import GHC.Types.Id import GHC.Types.TypeEnv import GHC.Types.Basic import GHC.Types.SrcLoc -import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.TyThing @@ -99,7 +91,6 @@ import GHC.Data.Bag import Control.Monad import Control.Monad.Trans.Class ( lift ) -import Data.Semigroup import Data.List.NonEmpty ( NonEmpty ) import Data.Foldable ( toList ) @@ -1956,89 +1947,3 @@ finding the free type vars of an expression is necessarily monadic operation. (consider /\a -> f @ b, where b is side-effected to a) -} -{- -************************************************************************ -* * - Checking for coercion holes -* * -************************************************************************ --} - --- | Is a coercion hole filled in? -isFilledCoercionHole :: CoercionHole -> TcM Bool -isFilledCoercionHole (CoercionHole { ch_ref = ref }) - = isJust <$> readTcRef ref - --- | Retrieve the contents of a coercion hole. Panics if the hole --- is unfilled -unpackCoercionHole :: CoercionHole -> TcM Coercion -unpackCoercionHole hole - = do { contents <- unpackCoercionHole_maybe hole - ; case contents of - Just co -> return co - Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } - --- | Retrieve the contents of a coercion hole, if it is filled -unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion) -unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref - -zonkCtRewriterSet :: Ct -> TcM Ct -zonkCtRewriterSet ct - | isGivenCt ct - = return ct - | otherwise - = case ct of - CEqCan eq@(EqCt { eq_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CEqCan (eq { eq_ev = ev' })) } - CIrredCan ir@(IrredCt { ir_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CIrredCan (ir { ir_ev = ev' })) } - CDictCan di@(DictCt { di_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CDictCan (di { di_ev = ev' })) } - CQuantCan {} -> return ct - CNonCanonical ev -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CNonCanonical ev') } - -zonkCtEvRewriterSet :: CtEvidence -> TcM CtEvidence -zonkCtEvRewriterSet ev@(CtGiven {}) - = return ev -zonkCtEvRewriterSet ev@(CtWanted wtd) - = do { rewriters' <- zonkRewriterSet (ctEvRewriters ev) - ; return (CtWanted $ setWantedCtEvRewriters wtd rewriters') } - --- | Check whether any coercion hole in a RewriterSet is still unsolved. --- Does this by recursively looking through filled coercion holes until --- one is found that is not yet filled in, at which point this aborts. -zonkRewriterSet :: RewriterSet -> TcM RewriterSet -zonkRewriterSet (RewriterSet set) - = nonDetStrictFoldUniqSet go (return emptyRewriterSet) set - -- this does not introduce non-determinism, because the only - -- monadic action is to read, and the combining function is - -- commutative - where - go :: CoercionHole -> TcM RewriterSet -> TcM RewriterSet - go hole m_acc = unionRewriterSet <$> check_hole hole <*> m_acc - - check_hole :: CoercionHole -> TcM RewriterSet - check_hole hole = do { m_co <- unpackCoercionHole_maybe hole - ; case m_co of - Nothing -> return (unitRewriterSet hole) - Just co -> unUCHM (check_co co) } - - check_ty :: Type -> UnfilledCoercionHoleMonoid - check_co :: Coercion -> UnfilledCoercionHoleMonoid - (check_ty, _, check_co, _) = foldTyCo folder () - - folder :: TyCoFolder () UnfilledCoercionHoleMonoid - folder = TyCoFolder { tcf_view = noView - , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv) - , tcf_covar = \ _ cv -> check_ty (varType cv) - , tcf_hole = \ _ -> UCHM . check_hole - , tcf_tycobinder = \ _ _ _ -> () } - -newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: TcM RewriterSet } - -instance Semigroup UnfilledCoercionHoleMonoid where - UCHM l <> UCHM r = UCHM (unionRewriterSet <$> l <*> r) - -instance Monoid UnfilledCoercionHoleMonoid where - mempty = UCHM (return emptyRewriterSet) ===================================== testsuite/tests/indexed-types/should_fail/T3330c.stderr ===================================== @@ -1,16 +1,24 @@ - -T3330c.hs:25:43: error: [GHC-18872] - • Couldn't match kind ‘* -> *’ with ‘*’ - When matching types - f1 :: * -> * - f1 x :: * - Expected: Der ((->) x) (Der f1 x) - Actual: R f1 - • In the first argument of ‘plug’, namely ‘rf’ +T3330c.hs:25:38: error: [GHC-25897] + • Could not deduce ‘Der f1 ~ f1’ + from the context: f ~ (f1 :+: g) + bound by a pattern with constructor: + RSum :: forall (f :: * -> *) (g :: * -> *). + R f -> R g -> R (f :+: g), + in an equation for ‘plug'’ + at T3330c.hs:25:8-17 + Expected: x -> f1 x + Actual: x -> Der f1 x + ‘f1’ is a rigid type variable bound by + a pattern with constructor: + RSum :: forall (f :: * -> *) (g :: * -> *). + R f -> R g -> R (f :+: g), + in an equation for ‘plug'’ + at T3330c.hs:25:8-17 + • The function ‘plug’ is applied to three visible arguments, + but its type ‘Rep f => Der f x -> x -> f x’ has only two In the first argument of ‘Inl’, namely ‘(plug rf df x)’ In the expression: Inl (plug rf df x) • Relevant bindings include - x :: x (bound at T3330c.hs:25:29) df :: Der f1 x (bound at T3330c.hs:25:25) rf :: R f1 (bound at T3330c.hs:25:13) - plug' :: R f -> Der f x -> x -> f x (bound at T3330c.hs:25:1) + ===================================== testsuite/tests/indexed-types/should_fail/T4174.stderr ===================================== @@ -1,6 +1,16 @@ - -T4174.hs:45:12: error: [GHC-18872] - • Couldn't match type ‘False’ with ‘True’ - arising from a use of ‘sync_large_objects’ +T4174.hs:45:12: error: [GHC-25897] + • Couldn't match type ‘a’ with ‘SmStep’ + Expected: m (Field (Way (GHC6'8 minor) n t p) a b) + Actual: m (Field (WayOf m) SmStep RtsSpinLock) + ‘a’ is a rigid type variable bound by + the type signature for: + testcase :: forall (m :: * -> *) minor n t p a b. + Monad m => + m (Field (Way (GHC6'8 minor) n t p) a b) + at T4174.hs:44:1-63 • In the expression: sync_large_objects In an equation for ‘testcase’: testcase = sync_large_objects + • Relevant bindings include + testcase :: m (Field (Way (GHC6'8 minor) n t p) a b) + (bound at T4174.hs:45:1) + ===================================== testsuite/tests/indexed-types/should_fail/T8227.stderr ===================================== @@ -13,12 +13,3 @@ T8227.hs:24:27: error: [GHC-83865] absoluteToParam :: Scalar (V a) -> a -> Scalar (V a) (bound at T8227.hs:24:1) -T8227.hs:24:48: error: [GHC-27958] - • Couldn't match type ‘p0’ with ‘Scalar (V p0)’ - arising from a type equality Scalar (V a) ~ Scalar (V p0) -> p0 - The type variable ‘p0’ is ambiguous - • In the second argument of ‘arcLengthToParam’, namely ‘eps’ - In the expression: arcLengthToParam eps eps - In an equation for ‘absoluteToParam’: - absoluteToParam eps seg = arcLengthToParam eps eps - ===================================== testsuite/tests/typecheck/should_fail/T18851.stderr ===================================== @@ -1,7 +1,7 @@ - T18851.hs:35:5: error: [GHC-18872] - • Couldn't match type ‘B’ with ‘A’ - arising from a superclass required to satisfy ‘C int0 A’, + • Couldn't match type ‘Bool’ with ‘B’ + arising from a superclass required to satisfy ‘C Int B’, arising from a use of ‘f’ • In the expression: f @A @B In an equation for ‘g’: g = f @A @B + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be011dacff5ef7a07d59ecd52ef5c6e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be011dacff5ef7a07d59ecd52ef5c6e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T25974
by Serge S. Gulin (＠gulin.serge) 18 Apr '25

18 Apr '25

Serge S. Gulin pushed new branch wip/T25974 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T25974 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/25974
by Serge S. Gulin (＠gulin.serge) 18 Apr '25

18 Apr '25

Serge S. Gulin deleted branch wip/25974 at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/25974
by Serge S. Gulin (＠gulin.serge) 18 Apr '25

18 Apr '25

Serge S. Gulin pushed new branch wip/25974 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/25974 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/T24603-wine
by Serge S. Gulin (＠gulin.serge) 18 Apr '25

18 Apr '25

Serge S. Gulin deleted branch wip/T24603-wine at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T24603-wine
by Serge S. Gulin (＠gulin.serge) 18 Apr '25

18 Apr '25

Serge S. Gulin pushed new branch wip/T24603-wine at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24603-wine You're receiving this email because of your account on gitlab.haskell.org.

1 0