[Git][ghc/ghc][wip/T23162-spj] 2 commits: Tidy up trySolveImplication
by Simon Peyton Jones (ļ¼ simonpj) 15 Oct '25
by Simon Peyton Jones (ļ¼ simonpj) 15 Oct '25
15 Oct '25
Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC
Commits:
17e57012 by Simon Peyton Jones at 2025-10-14T22:22:20+01:00
Tidy up trySolveImplication
This completes some leftover mess from
commit 14123ee646f2b9738a917b7cec30f9d3941c13de
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Wed Aug 20 00:35:48 2025 +0100
Solve forall-constraints via an implication, again
- - - - -
addfb498 by Simon Peyton Jones at 2025-10-15T22:26:30+01:00
Big increment in rewriter tracking
Needs more documentation
- - - - -
11 changed files:
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Irred.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Solver/Solve.hs-boot
- compiler/GHC/Tc/Types/Constraint.hs
- testsuite/tests/perf/compiler/T8095.hs
- testsuite/tests/perf/compiler/T9872a.hs
Changes:
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -1690,6 +1690,8 @@ data CoercionHole
-- See Note [CoercionHoles and coercion free variables]
, ch_ref :: IORef (Maybe (Coercion, RewriterSet))
+ -- The RewriterSet is (possibly a superset of)
+ -- the free coercion holes of the coercion
}
coHoleCoVar :: CoercionHole -> CoVar
=====================================
compiler/GHC/Tc/Solver/Default.hs
=====================================
@@ -447,7 +447,7 @@ defaultExceptionContext ct
; empty_ec_id <- lookupId emptyExceptionContextName
; let ev = ctEvidence ct
ev_tm = EvExpr (evWrapIPE (ctEvPred ev) (Var empty_ec_id))
- ; setEvBindIfWanted ev EvCanonical ev_tm
+ ; setDictIfWanted ev EvCanonical ev_tm
-- EvCanonical: see Note [CallStack and ExceptionContext hack]
-- in GHC.Tc.Solver.Dict
; return True }
@@ -541,8 +541,7 @@ defaultEquality encl_eqs ct
= do { traceTcS "defaultEquality success:" (ppr rhs_ty)
; unifyTyVar lhs_tv rhs_ty -- NB: unifyTyVar adds to the
-- TcS unification counter
- ; setEvBindIfWanted (ctEvidence ct) EvCanonical $
- evCoercion (mkReflCo Nominal rhs_ty)
+ ; setEqIfWanted (ctEvidence ct) emptyRewriterSet (mkReflCo Nominal rhs_ty)
; return True
}
@@ -567,8 +566,7 @@ defaultEquality encl_eqs ct
-- See Note [Defaulting representational equalities].
; if null new_eqs
then do { traceTcS "defaultEquality ReprEq } (yes)" empty
- ; setEvBindIfWanted (ctEvidence ct) EvCanonical $
- evCoercion $ mkSubCo co
+ ; setEqIfWanted (ctEvidence ct) emptyRewriterSet (mkSubCo co)
; return True }
else do { traceTcS "defaultEquality ReprEq } (no)" empty
; return False } }
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -178,7 +178,7 @@ solveCallStack ev ev_cs
-- `IP ip CallStack`. See Note [Overview of implicit CallStacks]
= do { inner_stk <- evCallStack pred ev_cs
; let ev_tm = EvExpr (evWrapIPE pred inner_stk)
- ; setEvBindIfWanted ev EvCanonical ev_tm }
+ ; setDictIfWanted ev EvCanonical ev_tm }
-- EvCanonical: see Note [CallStack and ExceptionContext hack]
where
pred = ctEvPred ev
@@ -394,9 +394,18 @@ There are two more similar "equality classes" like this. The full list is
* Coercible coercibleTyCon
(See Note [The equality types story] in GHC.Builtin.Types.Prim.)
-(EQC1) For Givens, when expanding the superclasses of a equality class,
- we can /replace/ the constraint with its superclasses (which, remember, are
- equally powerful) rather than /adding/ them. This can make a huge difference.
+(EQC1) For a Given (boxed) equality like (t1 ~ t2), we /replace/ the constraint
+ with its superclass (which, remember, is equally powerful) rather than /adding/
+ it. Thus, we turn [G] d : t1 ~ t2 into
+ [G] g : t1 ~# t2
+ g := sc_sel d -- Extend the evidence bindings
+
+ We achieve this by
+ (a) not expanding superclasses for equality classes at all;
+ see the `isEqualityClass` test in `mk_strict_superclasses`
+ (b) special logic to solve (t1 ~ t2) in the Given case of `solveEqualityDict`.
+
+ Using replacement rather than adding can make a huge difference.
Consider T17836, which has a constraint like
forall b,c. a ~ (b,c) =>
forall d,e. c ~ (d,e) =>
@@ -411,11 +420,6 @@ There are two more similar "equality classes" like this. The full list is
pattern matching. Its compile-time allocation decreased by 40% when
I added the "replace" rather than "add" semantics.)
- We achieve this by
- (a) not expanding superclasses for equality classes at all;
- see the `isEqualityClass` test in `mk_strict_superclasses`
- (b) special logic to solve (t1 ~ t2) in `solveEqualityDict`.
-
(EQC2) Faced with [W] t1 ~ t2, it's always OK to reduce it to [W] t1 ~# t2,
without worrying about Note [Instance and Given overlap]. Why? Because
if we had [G] s1 ~ s2, then we'd get the superclass [G] s1 ~# s2, and
@@ -468,26 +472,29 @@ solveEqualityDict :: CtEvidence -> Class -> [Type] -> SolverStage Void
-- See Note [Solving equality classes]
-- Precondition: (isEqualityClass cls) True, so cls is (~), (~~), or Coercible
solveEqualityDict ev cls tys
+ | CtGiven (GivenCt { ctev_evar = ev_id }) <- ev
+ , [sel_id] <- classSCSelIds cls -- Equality classes have just one superclass
+ = Stage $
+ do { let loc = ctEvLoc ev
+ sc_pred = classMethodInstTy sel_id tys
+ ev_expr = EvExpr $ Var sel_id `mkTyApps` tys `App` evId ev_id
+ -- See (EQC1) in Note [Solving equality classes]
+ -- This call to newGivenEv makes the evidence binding for the (unboxed) coercion
+ ; given_ev <- newGivenEv loc (sc_pred, ev_expr)
+ ; startAgainWith (mkNonCanonical $ CtGiven given_ev) }
+
| CtWanted (WantedCt { ctev_dest = dest }) <- ev
= Stage $
do { let (role, t1, t2) = matchEqualityInst cls tys
-- Unify t1~t2, putting anything that can't be solved
-- immediately into the work list
- ; co <- wrapUnifierAndEmit ev role $ \uenv ->
- uType uenv t1 t2
+ ; (co,_rws) <- wrapUnifierAndEmit ev role $ \uenv ->
+ uType uenv t1 t2
-- Set d :: (t1~t2) = Eq# co
; setWantedDict dest EvCanonical $
evDictApp cls tys [Coercion co]
; stopWith ev "Solved wanted lifted equality" }
- | CtGiven (GivenCt { ctev_evar = ev_id }) <- ev
- , [sel_id] <- classSCSelIds cls -- Equality classes have just one superclass
- = Stage $
- do { let loc = ctEvLoc ev
- sc_pred = classMethodInstTy sel_id tys
- ev_expr = EvExpr $ Var sel_id `mkTyApps` tys `App` evId ev_id
- ; given_ev <- newGivenEv loc (sc_pred, ev_expr)
- ; startAgainWith (mkNonCanonical $ CtGiven given_ev) }
| otherwise
= pprPanic "solveEqualityDict" (ppr cls)
@@ -730,10 +737,10 @@ try_inert_dicts inerts dict_w@(DictCt { di_ev = ev_w, di_cls = cls, di_tys = tys
| otherwise -- We can either solve the inert from the work-item or vice-versa.
-> case solveOneFromTheOther (CDictCan dict_i) (CDictCan dict_w) of
KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr dict_w)
- ; setEvBindIfWanted ev_w EvCanonical (ctEvTerm ev_i)
+ ; setDictIfWanted ev_w EvCanonical (ctEvTerm ev_i)
; return $ Stop ev_w (text "Dict equal" <+> ppr dict_w) }
KeepWork -> do { traceTcS "lookupInertDict:KeepWork" (ppr dict_w)
- ; setEvBindIfWanted ev_i EvCanonical (ctEvTerm ev_w)
+ ; setDictIfWanted ev_i EvCanonical (ctEvTerm ev_w)
; updInertCans (updDicts $ delDict dict_w)
; continueWith () } }
@@ -796,7 +803,7 @@ try_instances inerts work_item@(DictCt { di_ev = ev, di_cls = cls
-- See Note [No Given/Given fundeps]
| Just solved_ev <- lookupSolvedDict inerts cls xis -- Cached
- = do { setEvBindIfWanted ev EvCanonical (ctEvTerm solved_ev)
+ = do { setDictIfWanted ev EvCanonical (ctEvTerm solved_ev)
; stopWith ev "Dict/Top (cached)" }
| otherwise -- Wanted, but not cached
@@ -828,7 +835,7 @@ chooseInstance work_item
; assertPprM (getTcEvBindsVar >>= return . not . isCoEvBindsVar)
(ppr work_item)
; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta
- ; setEvBindIfWanted work_item canonical (mk_ev (map getEvExpr evc_vars))
+ ; setDictIfWanted work_item canonical (mk_ev (map getEvExpr evc_vars))
; emitWorkNC (map CtWanted $ freshGoals evc_vars)
; stopWith work_item "Dict/Top (solved wanted)" }
where
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -10,7 +10,7 @@ module GHC.Tc.Solver.Equality(
import GHC.Prelude
-import {-# SOURCE #-} GHC.Tc.Solver.Solve( trySolveImplication )
+import {-# SOURCE #-} GHC.Tc.Solver.Solve( solveSimpleWanteds )
import GHC.Tc.Solver.Irred( solveIrred )
import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance )
@@ -372,7 +372,7 @@ can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
-- Literals
can_eq_nc _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
| l1 == l2
- = do { setEvBindIfWanted ev EvCanonical (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)
+ = do { setEqIfWanted ev emptyRewriterSet (mkReflCo (eqRelRole eq_rel) ty1)
; stopWith ev "Equal LitTy" }
-- Decompose FunTy: (s -> t) and (c => t)
@@ -485,7 +485,7 @@ can_eq_nc_forall :: CtEvidence -> EqRel
-- See Note [Solving forall equalities]
can_eq_nc_forall ev eq_rel s1 s2
- | CtWanted (WantedCt { ctev_dest = orig_dest, ctev_rewriters = rws, ctev_loc = loc }) <- ev
+ | CtWanted (WantedCt { ctev_dest = orig_dest }) <- ev
= do { let (bndrs1, phi1, bndrs2, phi2) = split_foralls s1 s2
flags1 = binderFlags bndrs1
flags2 = binderFlags bndrs2
@@ -541,36 +541,40 @@ can_eq_nc_forall ev eq_rel s1 s2
; traceTcS "Generating wanteds" (ppr s1 $$ ppr s2)
- -- Generate the constraints that live in the body of the implication
- -- See (SF5) in Note [Solving forall equalities]
- ; (unifs, (lvl, (all_co, wanteds)))
- <- reportFineGrainUnifications $
- pushLevelNoWorkList (ppr skol_info) $
- wrapUnifier ev (eqRelRole eq_rel) $ \uenv ->
- go uenv skol_tvs init_subst2 bndrs1 bndrs2
+ -- Generate and solve the constraints that live in the body of the implication
+ -- See (SF5) and (SF6) in Note [Solving forall equalities]
+ ; (unifs, (all_co, solved))
+ <- reportFineGrainUnifications $
+ do { -- Generate constraints
+ (tclvl, (all_co, wanteds))
+ <- pushLevelNoWorkList (ppr skol_info) $
+ wrapUnifier ev (eqRelRole eq_rel) $ \uenv ->
+ go uenv skol_tvs init_subst2 bndrs1 bndrs2
+
+ ; traceTcS "Trying to solve the implication" (ppr s1 $$ ppr s2 $$ ppr wanteds)
+
+ -- Solve the `wanteds` in a nested context
+ ; ev_binds_var <- newNoTcEvBinds
+ ; residual_wanted <- nestImplicTcS skol_info_anon ev_binds_var tclvl $
+ solveSimpleWanteds wanteds
+
+ ; return (all_co, isSolvedWC residual_wanted) }
+
-- Kick out any inerts constraints that mention unified type variables
; kickOutAfterUnification unifs
- -- Solve the implication right away, using `trySolveImplication`
- -- See (SF6) in Note [Solving forall equalities]
- ; traceTcS "Trying to solve the implication" (ppr s1 $$ ppr s2 $$ ppr wanteds)
- ; ev_binds_var <- newNoTcEvBinds
- ; solved <- trySolveImplication $
- (implicationPrototype (ctLocEnv loc))
- { ic_tclvl = lvl
- , ic_binds = ev_binds_var
- , ic_info = skol_info_anon
- , ic_warn_inaccessible = False
- , ic_skols = skol_tvs
- , ic_given = []
- , ic_wanted = emptyWC { wc_simple = wanteds } }
-
; if solved
- then do { -- all_co <- zonkCo all_co
- -- -- ToDo: explain this zonk
- setWantedEq orig_dest rws all_co
+ then do { all_co <- zonkCo all_co
+ -- setWantedEq will add `all_co` to the `ebv_tcvs`, to record
+ -- that `all_co` is used. But if `all_co` contains filled
+ -- CoercionHoles, from the nested solve, and we may miss the
+ -- use of CoVars. Test T7196 showed this up
+
+ ; setWantedEq orig_dest emptyRewriterSet all_co
+ -- emptyRewriterSet: fully solved, so all_co has no holes
; stopWith ev "Polytype equality: solved" }
+
else canEqSoftFailure IrredShapeReason ev s1 s2 } }
| otherwise
@@ -592,11 +596,12 @@ can_eq_nc_forall ev eq_rel s1 s2
in (bndr1:bndrs1, phi1, bndr2:bndrs2, phi2)
split_foralls s1 s2 = ([], s1, [], s2)
+
{- Note [Solving forall equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To solve an equality between foralls
[W] (forall a. t1) ~ (forall b. t2)
-the basic plan is simple: use `trySolveImplication` to solve the
+the basic plan is simple: behave rather as if we were solving the
implication constraint
[W] forall a. { t1 ~ (t2[a/b]) }
@@ -643,19 +648,15 @@ There are lots of wrinkles of course:
because we want to /gather/ the equality constraint (to put in the implication)
rather than /emit/ them into the monad, as `wrapUnifierAndEmit` does.
-(SF6) We solve the implication on the spot, using `trySolveImplication`. In
- the past we instead generated an `Implication` to be solved later. Nice in
- some ways but it added complexity:
- - We needed a `wl_implics` field of `WorkList` to collect
- these emitted implications
- - The types of `solveSimpleWanteds` and friends were more complicated
- - Trickily, an `EvFun` had to contain an `EvBindsVar` ref-cell, which made
- `evVarsOfTerm` harder. Now an `EvFun` just contains the bindings.
- The disadvantage of solve-on-the-spot is that if we fail we are simply
- left with an unsolved (forall a. blah) ~ (forall b. blah), and it may
- not be clear /why/ we couldn't solve it. But on balance the error messages
- improve: it is easier to undertand that
- (forall a. a->a) ~ (forall b. b->Int)
+(SF6) We solve the nested constraints right away. In the past we instead generated
+ an `Implication` to be solved later, but we no longer have a convenient place
+ to accumulate such an implication for later solving. Instead we just try to solve
+ them on the spot, and abandon the attempt if we fail.
+
+ In the latter case we are left with an unsolved (forall a. blah) ~ (forall b. blah),
+ and it may not be clear /why/ we couldn't solve it. But on balance the error
+ messages improve: it is easier to understand that
+ (forall a. a->a) ~ (forall b. b->Int)
is insoluble than it is to understand a message about matching `a` with `Int`.
-}
@@ -809,11 +810,11 @@ can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2
-- to an irreducible constraint; see typecheck/should_compile/T10494
-- See Note [Decomposing AppTy equalities]
can_eq_app ev s1 t1 s2 t2
- | CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rws }) <- ev
+ | CtWanted (WantedCt { ctev_dest = dest }) <- ev
= do { traceTcS "can_eq_app" (vcat [ text "s1:" <+> ppr s1, text "t1:" <+> ppr t1
, text "s2:" <+> ppr s2, text "t2:" <+> ppr t2
, text "vis:" <+> ppr (isNextArgVisible s1) ])
- ; co <- wrapUnifierAndEmit ev Nominal $ \uenv ->
+ ; (co,rws) <- wrapUnifierAndEmit ev Nominal $ \uenv ->
-- Unify arguments t1/t2 before function s1/s2, because
-- the former have smaller kinds, and hence simpler error messages
-- c.f. GHC.Tc.Utils.Unify.uType (go_app)
@@ -1374,11 +1375,11 @@ canDecomposableTyConAppOK ev eq_rel tc (ty1,tys1) (ty2,tys2)
do { traceTcS "canDecomposableTyConAppOK"
(ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)
; case ev of
- CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rws })
+ CtWanted (WantedCt { ctev_dest = dest })
-- new_locs and tc_roles are both infinite, so we are
-- guaranteed that cos has the same length as tys1 and tys2
-- See Note [Fast path when decomposing TyConApps]
- -> do { co <- wrapUnifierAndEmit ev role $ \uenv ->
+ -> do { (co,rws) <- wrapUnifierAndEmit ev role $ \uenv ->
do { cos <- zipWith4M (u_arg uenv) new_locs tc_roles tys1 tys2
-- zipWith4M: see Note [Work-list ordering]
; return (mkTyConAppCo role tc cos) }
@@ -1432,8 +1433,8 @@ canDecomposableFunTy ev eq_rel af f1@(ty1,m1,a1,r1) f2@(ty2,m2,a2,r2)
= do { traceTcS "canDecomposableFunTy"
(ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2)
; case ev of
- CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rws })
- -> do { co <- wrapUnifierAndEmit ev Nominal $ \ uenv ->
+ CtWanted (WantedCt { ctev_dest = dest })
+ -> do { (co,rws) <- wrapUnifierAndEmit ev Nominal $ \ uenv ->
do { let mult_env = uenv `updUEnvLoc` toInvisibleLoc InvisibleMultiplicity
`setUEnvRole` funRole role SelMult
; mult <- uType mult_env m1 m2
@@ -2011,6 +2012,7 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs
then return ev
else rewriteEqEvidence emptyRewriterSet ev swapped
(mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn
+ -- emptyRewriterSet: rhs_redn has no CoercionHoles
; let tv_ty = mkTyVarTy tv
final_rhs = reductionReducedType rhs_redn
@@ -2026,8 +2028,7 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs
-- Provide Refl evidence for the constraint
-- Ignore 'swapped' because it's Refl!
- ; setEvBindIfWanted new_ev EvCanonical $
- evCoercion (mkNomReflCo final_rhs)
+ ; setEqIfWanted new_ev emptyRewriterSet (mkNomReflCo final_rhs)
-- Kick out any constraints that can now be rewritten
; kickOutAfterUnification (unitVarSet tv)
@@ -2147,8 +2148,7 @@ canEqReflexive :: CtEvidence -- ty ~ ty
-> TcType -- ty
-> TcS (StopOrContinue a) -- always Stop
canEqReflexive ev eq_rel ty
- = do { setEvBindIfWanted ev EvCanonical $
- evCoercion (mkReflCo (eqRelRole eq_rel) ty)
+ = do { setEqIfWanted ev emptyRewriterSet (mkReflCo (eqRelRole eq_rel) ty)
; stopWith ev "Solved by reflexivity" }
{- Note [Equalities with heterogeneous kinds]
@@ -2649,10 +2649,11 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio
| CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rewriters }) <- old_ev
= do { let rewriters' = rewriters S.<> new_rewriters
- ; (new_ev, hole_co) <- newWantedEq loc rewriters' (ctEvRewriteRole old_ev) nlhs nrhs
+ ; (new_ev, hole) <- newWantedEq loc rewriters' (ctEvRewriteRole old_ev) nlhs nrhs
; let co = maybeSymCo swapped $
- lhs_co `mkTransCo` hole_co `mkTransCo` mkSymCo rhs_co
- ; setWantedEq dest rewriters' co
+ lhs_co `mkTransCo` mkHoleCo hole `mkTransCo` mkSymCo rhs_co
+ -- new_rewriters has all the holes from lhs_co and rhs_co
+ ; setWantedEq dest (new_rewriters `mappend` unitRewriterSet hole) co
; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev
, ppr nlhs
, ppr nrhs
@@ -2730,11 +2731,11 @@ tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel })
= Stage $
do { inerts <- getInertCans
; if | Just (ev_i, swapped) <- inertsEqsCanDischarge inerts work_item
- -> do { setEvBindIfWanted ev EvCanonical $
- evCoercion (maybeSymCo swapped $
- downgradeRole (eqRelRole eq_rel)
- (ctEvRewriteRole ev_i)
- (ctEvCoercion ev_i))
+ -> do { setEqIfWanted ev (ctEvRewriterSet ev_i) $
+ maybeSymCo swapped $
+ downgradeRole (eqRelRole eq_rel)
+ (ctEvRewriteRole ev_i)
+ (ctEvCoercion ev_i)
; stopWith ev "Solved from inert" }
| otherwise
=====================================
compiler/GHC/Tc/Solver/Irred.hs
=====================================
@@ -14,11 +14,10 @@ import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance )
import GHC.Tc.Solver.Monad
import GHC.Tc.Types.Evidence
-import GHC.Core.Coercion
-
import GHC.Types.Basic( SwapFlag(..) )
import GHC.Utils.Outputable
+import GHC.Utils.Panic
import GHC.Data.Bag
@@ -69,9 +68,9 @@ try_inert_irreds inerts irred_w@(IrredCt { ir_ev = ev_w, ir_reason = reason })
vcat [ text "wanted:" <+> (ppr ct_w $$ ppr (ctOrigin ct_w))
, text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) ]
; case solveOneFromTheOther ct_i ct_w of
- KeepInert -> do { setEvBindIfWanted ev_w EvCanonical (swap_me swap ev_i)
+ KeepInert -> do { setIrredIfWanted ev_w swap ev_i
; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) }
- KeepWork -> do { setEvBindIfWanted ev_i EvCanonical (swap_me swap ev_w)
+ KeepWork -> do { setIrredIfWanted ev_i swap ev_w
; updInertCans (updIrreds (\_ -> others))
; continueWith () } }
@@ -81,12 +80,19 @@ try_inert_irreds inerts irred_w@(IrredCt { ir_ev = ev_w, ir_reason = reason })
where
ct_w = CIrredCan irred_w
- swap_me :: SwapFlag -> CtEvidence -> EvTerm
- swap_me swap ev
- = case swap of
- NotSwapped -> ctEvTerm ev
- IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev)))
-
+setIrredIfWanted :: CtEvidence -> SwapFlag -> CtEvidence -> TcS ()
+-- Irreds can be equalities or dictionaries
+setIrredIfWanted ev_dest swap ev_source
+ | CtWanted (WantedCt { ctev_dest = dest }) <- ev_dest
+ = case dest of
+ HoleDest {} -> setWantedEq dest (ctEvRewriterSet ev_source)
+ (maybeSymCo swap (ctEvCoercion ev_source))
+
+ EvVarDest {} -> assertPpr (swap==NotSwapped) (ppr ev_dest $$ ppr ev_source) $
+ -- findMatchingIrreds only returns IsSwapped for equalities
+ setWantedDict dest EvCanonical (ctEvTerm ev_source)
+ | otherwise
+ = return ()
{- Note [Multiple matching irreds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -50,13 +50,12 @@ module GHC.Tc.Solver.Monad (
CanonicalEvidence(..),
newTcEvBinds, newNoTcEvBinds,
- newWantedEq, emitNewWantedEq,
+ newWantedEq,
newWanted,
newWantedNC, newWantedEvVarNC,
newBoundEvVarId,
unifyTyVar, reportFineGrainUnifications, reportCoarseGrainUnifications,
- setEvBind, setWantedEq, setWantedDict,
- setWantedEvTerm, setEvBindIfWanted,
+ setEvBind, setWantedEq, setWantedDict, setEqIfWanted, setDictIfWanted,
newEvVar, newGivenEv, emitNewGivens,
emitChildEqs, checkReductionDepth,
@@ -1209,12 +1208,28 @@ setTcLevelTcS :: TcLevel -> TcS a -> TcS a
setTcLevelTcS lvl (TcS thing_inside)
= TcS $ \ env -> TcM.setTcLevel lvl (thing_inside env)
+{- Note [nestImplicTcS]
+~~~~~~~~~~~~~~~~~~~~~~~
+`nestImplicTcS` is used to build a nested scope when we begin solving an implication.
+
+(NI1) One subtle point is that `nestImplicTcS` uses `resetInertCans` to
+ initialise the `InertSet` of the nested scope to the `inert_givens` (/not/
+ the `inert_cans`) of the current inert set. It is super-important not to
+ pollute the sub-solving problem with the unsolved Wanteds of the current
+ scope.
+
+ Whenever we do `solveSimpleGivens`, we snapshot the `inert_cans` into `inert_givens`.
+ (At that moment there should be no Wanteds.)
+-}
+
nestImplicTcS :: SkolemInfoAnon -> EvBindsVar
-> TcLevel -> TcS a
-> TcS a
+-- See Note [nestImplicTcS]
nestImplicTcS skol_info ev_binds_var inner_tclvl (TcS thing_inside)
= TcS $ \ env@(TcSEnv { tcs_inerts = old_inert_var }) ->
- do { nest_inert <- mk_nested_inert_set skol_info old_inert_var
+ do { old_inerts <- TcM.readTcRef old_inert_var
+ ; let nest_inert = mk_nested_inerts old_inerts
; new_inert_var <- TcM.newTcRef nest_inert
; new_wl_var <- TcM.newTcRef emptyWorkList
; let nest_env = env { tcs_ev_binds = ev_binds_var
@@ -1233,24 +1248,18 @@ nestImplicTcS skol_info ev_binds_var inner_tclvl (TcS thing_inside)
#endif
; return res }
where
- mk_nested_inert_set skol_info old_inert_var
+ mk_nested_inerts old_inerts
-- For an implication that comes from a static form (static e),
-- start with a completely empty inert set; in particular, no Givens
-- See (SF3) in Note [Grand plan for static forms]
-- in GHC.Iface.Tidy.StaticPtrTable
| StaticFormSkol <- skol_info
- = return (emptyInertSet inner_tclvl)
+ = emptyInertSet inner_tclvl
| otherwise
- = do { inerts <- TcM.readTcRef old_inert_var
-
- -- resetInertCans: initialise the inert_cans from the inert_givens of the
- -- parent so that the child is not polluted with the parent's inert Wanteds
- -- See Note [trySolveImplication] in GHC.Tc.Solver.Solve
- -- All other InertSet fields are inherited
- ; return (pushCycleBreakerVarStack $
- resetInertCans $
- inerts) }
+ = pushCycleBreakerVarStack $
+ resetInertCans $ -- See (NI1) in Note [nestImplicTcS]
+ old_inerts
nestFunDepsTcS :: TcS a -> TcS a
nestFunDepsTcS (TcS thing_inside)
@@ -1950,64 +1959,40 @@ addUsedCoercion co
= do { ev_binds_var <- getTcEvBindsVar
; wrapTcS (TcM.updTcRef (ebv_tcvs ev_binds_var) (co :)) }
+setEqIfWanted :: CtEvidence -> RewriterSet -> TcCoercion -> TcS ()
+setEqIfWanted ev rewriters co
+ = case ev of
+ CtWanted (WantedCt { ctev_dest = dest })
+ -> setWantedEq dest rewriters co
+ _ -> return ()
+
setWantedEq :: HasDebugCallStack => TcEvDest -> RewriterSet -> TcCoercion -> TcS ()
-- ^ Equalities only
-setWantedEq (HoleDest hole) rewriters co
- = do { addUsedCoercion co
- ; fillCoercionHole hole rewriters co }
-setWantedEq (EvVarDest ev) _ _ = pprPanic "setWantedEq: EvVarDest" (ppr ev)
+setWantedEq dest rewriters co
+ = case dest of
+ HoleDest hole -> fillCoercionHole hole rewriters co
+ EvVarDest ev -> pprPanic "setWantedEq: EvVarDest" (ppr ev)
+
+setDictIfWanted :: CtEvidence -> CanonicalEvidence -> EvTerm -> TcS ()
+setDictIfWanted ev canonical tm
+ = case ev of
+ CtWanted (WantedCt { ctev_dest = dest })
+ -> setWantedDict dest canonical tm
+ _ -> return ()
setWantedDict :: TcEvDest -> CanonicalEvidence -> EvTerm -> TcS ()
-- ^ Dictionaries only
-setWantedDict (EvVarDest ev_id) canonical tm
- = setEvBind (mkWantedEvBind ev_id canonical tm)
-setWantedDict (HoleDest h) _ _ = pprPanic "setWantedEq: HoleDest" (ppr h)
-
-setWantedEvTerm :: TcEvDest -> RewriterSet -> CanonicalEvidence -> EvTerm -> TcS ()
--- ^ Good for both equalities and non-equalities
-setWantedEvTerm (EvVarDest ev_id) _rewriters canonical tm
- = setEvBind (mkWantedEvBind ev_id canonical tm)
-setWantedEvTerm (HoleDest hole) rewriters _canonical tm
- | Just co <- evTermCoercion_maybe tm
- = do { addUsedCoercion co
- ; fillCoercionHole hole rewriters co }
- | otherwise
- = -- See Note [Yukky eq_sel for a HoleDest]
- do { let co_var = coHoleCoVar hole
- ; setEvBind (mkWantedEvBind co_var EvCanonical tm)
- ; fillCoercionHole hole rewriters (mkCoVarCo co_var) }
-
-{- Note [Yukky eq_sel for a HoleDest]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-How can it be that a Wanted with HoleDest gets evidence that isn't
-just a coercion? i.e. evTermCoercion_maybe returns Nothing.
-
-Consider [G] forall a. blah => a ~ T
- [W] S ~# T
-
-Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ T)
-in the quantified constraints, and wraps the (boxed) evidence it
-gets back in an eq_sel to extract the unboxed (S ~# T). We can't put
-that term into a coercion, so we add a value binding
- h = eq_sel (...)
-and the coercion variable h to fill the coercion hole.
-We even re-use the CoHole's Id for this binding!
-
-Yuk!
--}
+setWantedDict dest canonical tm
+ = case dest of
+ EvVarDest ev_id -> setEvBind (mkWantedEvBind ev_id canonical tm)
+ HoleDest h -> pprPanic "setWantedEq: HoleDest" (ppr h)
fillCoercionHole :: CoercionHole -> RewriterSet -> Coercion -> TcS ()
fillCoercionHole hole rewriters co
- = do { wrapTcS $ TcM.fillCoercionHole hole (co, rewriters)
+ = do { addUsedCoercion co
+ ; wrapTcS $ TcM.fillCoercionHole hole (co, rewriters)
; kickOutAfterFillingCoercionHole hole rewriters }
-setEvBindIfWanted :: CtEvidence -> CanonicalEvidence -> EvTerm -> TcS ()
-setEvBindIfWanted ev canonical tm
- = case ev of
- CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rewriters })
- -> setWantedEvTerm dest rewriters canonical tm
- _ -> return ()
-
newTcEvBinds :: TcS EvBindsVar
newTcEvBinds = wrapTcS TcM.newTcEvBinds
@@ -2019,9 +2004,11 @@ newEvVar pred = wrapTcS (TcM.newEvVar pred)
newGivenEv :: CtLoc -> (TcPredType, EvTerm) -> TcS GivenCtEvidence
-- Make a new variable of the given PredType,
--- immediately bind it to the given term
--- and return its CtEvidence
+-- immediately bind it to the given term, and return its CtEvidence
-- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint
+--
+-- The `pred` can be an /equality predicate/ t1 ~# t2;
+-- see (EQC1) in Note [Solving equality classes] in GHC.Tc.Solver.Dict
newGivenEv loc (pred, rhs)
= do { new_ev <- newBoundEvVarId pred rhs
; return $ GivenCt { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc } }
@@ -2044,13 +2031,6 @@ emitNewGivens loc pts
, not (ty1 `tcEqType` ty2) ] -- Kill reflexive Givens at birth
; emitWorkNC (map CtGiven gs) }
-emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion
--- | Emit a new Wanted equality into the work-list
-emitNewWantedEq loc rewriters role ty1 ty2
- = do { (wtd, co) <- newWantedEq loc rewriters role ty1 ty2
- ; updWorkListTcS (extendWorkListEq rewriters (mkNonCanonical $ CtWanted wtd))
- ; return co }
-
emitChildEqs :: CtEvidence -> Cts -> TcS ()
-- Emit a bunch of equalities into the work list
-- See Note [Work-list ordering] in GHC.Tc.Solver.Equality
@@ -2067,14 +2047,14 @@ emitChildEqs ev eqs
-- | Create a new Wanted constraint holding a coercion hole
-- for an equality between the two types at the given 'Role'.
newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType
- -> TcS (WantedCtEvidence, Coercion)
+ -> TcS (WantedCtEvidence, CoercionHole)
newWantedEq loc rewriters role ty1 ty2
= do { hole <- wrapTcS $ TcM.newCoercionHole pty
; let wtd = WantedCt { ctev_pred = pty
, ctev_dest = HoleDest hole
, ctev_loc = loc
, ctev_rewriters = rewriters }
- ; return (wtd, mkHoleCo hole) }
+ ; return (wtd, hole) }
where
pty = mkEqPredRole role ty1 ty2
@@ -2214,10 +2194,11 @@ uPairsTcM uenv eqns = mapM_ (\(Pair ty1 ty2) -> uType uenv ty1 ty2) eqns
wrapUnifierAndEmit :: CtEvidence -> Role
-> (UnifyEnv -> TcM a) -- Some calls to uType
- -> TcS a
+ -> TcS (a, RewriterSet)
-- Like wrapUnifier, but
-- emits any unsolved equalities into the work-list
-- kicks out any inert constraints that mention unified variables
+-- returns a RewriterSet describing the new unsolved goals
wrapUnifierAndEmit ev role do_unifications
= do { (unifs, (res, eqs)) <- reportFineGrainUnifications $
wrapUnifier ev role do_unifications
@@ -2228,7 +2209,7 @@ wrapUnifierAndEmit ev role do_unifications
-- Kick out any inert constraints mentioning the unified variables
; kickOutAfterUnification unifs
- ; return res }
+ ; return (res, rewriterSetFromCts eqs) }
wrapUnifier :: CtEvidence -> Role
-> (UnifyEnv -> TcM a) -- Some calls to uType
=====================================
compiler/GHC/Tc/Solver/Solve.hs
=====================================
@@ -7,7 +7,6 @@ module GHC.Tc.Solver.Solve (
solveWanteds, -- Solves WantedConstraints
solveSimpleGivens, -- Solves [Ct]
solveSimpleWanteds, -- Solves Cts
- trySolveImplication,
setImplicationStatus
) where
@@ -369,35 +368,6 @@ solveNestedImplications implics
; return unsolved_implics }
-{- Note [trySolveImplication]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-`trySolveImplication` may be invoked while solving simple wanteds, notably from
-`solveWantedForAll`. It returns a Bool to say if solving succeeded or failed.
-
-It uses `nestImplicTcS` to build a nested scope. One subtle point is that
-`nestImplicTcS` uses the `inert_givens` (not the `inert_cans`) of the current
-inert set to initialse the `InertSet` of the nested scope. It is super-important not
-to pollute the sub-solving problem with the unsolved Wanteds of the current scope.
-
-Whenever we do `solveSimpleGivens`, we snapshot the `inert_cans` into `inert_givens`.
-(At that moment there should be no Wanteds.)
--}
-
-trySolveImplication :: Implication -> TcS Bool
--- See Note [trySolveImplication]
-trySolveImplication (Implic { ic_tclvl = tclvl
- , ic_binds = ev_binds_var
- , ic_given = given_ids
- , ic_wanted = wanteds
- , ic_env = ct_loc_env
- , ic_info = info })
- = nestImplicTcS info ev_binds_var tclvl $
- do { let loc = mkGivenLoc tclvl info ct_loc_env
- givens = mkGivens loc given_ids
- ; solveSimpleGivens givens
- ; residual_wanted <- solveWanteds wanteds
- ; return (isSolvedWC residual_wanted) }
-
solveImplication :: Implication -- Wanted
-> TcS Implication -- Simplified implication
-- Precondition: The TcS monad contains an empty worklist and given-only inerts
@@ -1091,7 +1061,7 @@ solveSimpleGivens givens
-- Capture the Givens in the inert_givens of the inert set
-- for use by subsequent calls of nestImplicTcS
- -- See Note [trySolveImplication]
+ -- See Note [nestImplicTcS] in GHc.Tc.Solver.Monad
; updInertSet (\is -> is { inert_givens = inert_cans is })
; cans <- getInertCans
@@ -1273,7 +1243,7 @@ solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel
= solveEquality ev eq_rel (canEqLHSType lhs) rhs
solveCt (CQuantCan qci@(QCI { qci_ev = ev }))
- = do { ev' <- rewriteEvidence ev
+ = do { ev' <- rewriteDictEvidence ev
-- It is (much) easier to rewrite and re-classify than to
-- rewrite the pieces and build a Reduction that will rewrite
-- the whole constraint
@@ -1284,7 +1254,7 @@ solveCt (CQuantCan qci@(QCI { qci_ev = ev }))
_ -> pprPanic "SolveCt" (ppr ev) }
solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc }))
- = do { ev <- rewriteEvidence ev
+ = do { ev <- rewriteDictEvidence ev
-- It is easier to rewrite and re-classify than to rewrite
-- the pieces and build a Reduction that will rewrite the
-- whole constraint
@@ -1309,7 +1279,7 @@ solveNC ev
_ ->
-- Do rewriting on the constraint, especially zonking
- do { ev <- rewriteEvidence ev
+ do { ev <- rewriteDictEvidence ev
-- And then re-classify
; case classifyPredType (ctEvPred ev) of
@@ -1582,7 +1552,7 @@ try_inert_qcs (QCI { qci_ev = ev_w }) inerts =
; continueWith () }
ev_i:_ ->
do { traceTcS "tryInertQCs:KeepInert" (ppr ev_i)
- ; setEvBindIfWanted ev_w EvCanonical (ctEvTerm ev_i)
+ ; setDictIfWanted ev_w EvCanonical (ctEvTerm ev_i)
; stopWith ev_w "Solved Wanted forall-constraint from inert" }
where
matching_inert (QCI { qci_ev = ev_i })
@@ -1689,10 +1659,12 @@ solveWantedQCI _ ct = return (Left ct)
************************************************************************
-}
-rewriteEvidence :: CtEvidence -> SolverStage CtEvidence
--- (rewriteEvidence old_ev new_pred co do_next)
+rewriteDictEvidence :: CtEvidence -> SolverStage CtEvidence
+-- (rewriteDictEvidence old_ev new_pred co do_next)
-- Main purpose: create new evidence for new_pred;
-- unless new_pred is cached already
+-- Precondition: new_pred is not an equality: the evidence is a term-level
+-- thing, hence "Dict".
-- * Calls do_next with (new_ev :: new_pred), with same wanted/given flag as old_ev
-- * If old_ev was wanted, create a binding for old_ev, in terms of new_ev
-- * If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev
@@ -1723,8 +1695,8 @@ the rewriter set. We check this with an assertion.
-}
-rewriteEvidence ev
- = Stage $ do { traceTcS "rewriteEvidence" (ppr ev)
+rewriteDictEvidence ev
+ = Stage $ do { traceTcS "rewriteDictEvidence" (ppr ev)
; (redn, rewriters) <- rewrite ev (ctEvPred ev)
; finish_rewrite ev redn rewriters }
@@ -1761,8 +1733,8 @@ finish_rewrite
ev_rw_role = ctEvRewriteRole ev
; mb_new_ev <- newWanted loc rewriters' new_pred
; massert (coercionRole co == ev_rw_role)
- ; setWantedEvTerm dest rewriters' EvCanonical $
- evCast (getEvExpr mb_new_ev) $
+ ; setWantedDict dest EvCanonical $
+ evCast (getEvExpr mb_new_ev) $
downgradeRole Representational ev_rw_role (mkSymCo co)
; case mb_new_ev of
Fresh new_ev -> continueWith $ CtWanted new_ev
@@ -1826,17 +1798,22 @@ runTcPluginsWanted wanted
listToBag unsolved_wanted `andCts`
listToBag insols
- ; mapM_ setEv solved_wanted
+ ; mapM_ setPluginEv solved_wanted
; traceTcS "Finished plugins }" (ppr new_wanted)
; return ( notNull (pluginNewCts p), all_new_wanted ) } }
- where
- setEv :: (EvTerm,Ct) -> TcS ()
- setEv (ev,ct) = case ctEvidence ct of
- CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rewriters })
- -> setWantedEvTerm dest rewriters EvCanonical ev
- -- TODO: plugins should be able to signal non-canonicity
- _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"
+
+setPluginEv :: (EvTerm,Ct) -> TcS ()
+setPluginEv (tm,ct)
+ = case ctEvidence ct of
+ CtWanted (WantedCt { ctev_dest = dest })
+ -> case dest of
+ EvVarDest {} -> setWantedDict dest EvCanonical tm
+ -- TODO: plugins should be able to signal non-canonicity
+ HoleDest {} -> setWantedEq dest emptyRewriterSet (evTermCoercion tm)
+ -- TODO: should we try to track rewriters?
+
+ CtGiven {} -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"
-- | A pair of (given, wanted) constraints to pass to plugins
type SplitCts = ([Ct], [Ct])
=====================================
compiler/GHC/Tc/Solver/Solve.hs-boot
=====================================
@@ -1,8 +1,6 @@
module GHC.Tc.Solver.Solve where
-import Prelude( Bool )
import GHC.Tc.Solver.Monad( TcS )
-import GHC.Tc.Types.Constraint( Cts, Implication, WantedConstraints )
+import GHC.Tc.Types.Constraint( Cts, WantedConstraints )
solveSimpleWanteds :: Cts -> TcS WantedConstraints
-trySolveImplication :: Implication -> TcS Bool
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -80,7 +80,8 @@ module GHC.Tc.Types.Constraint (
ctEvExpr, ctEvTerm,
ctEvCoercion, givenCtEvCoercion,
ctEvEvId, wantedCtEvEvId,
- ctEvRewriters, setWantedCtEvRewriters, ctEvUnique, tcEvDestUnique,
+ ctEvRewriters, ctEvRewriterSet, setWantedCtEvRewriters,
+ ctEvUnique, tcEvDestUnique,
ctEvRewriteRole, ctEvRewriteEqRel, setCtEvPredType, setCtEvLoc,
tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList,
@@ -2291,7 +2292,8 @@ For Givens we make new EvVars and bind them immediately. Two main reasons:
f :: C a b => ....
Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b.
But that superclass selector can't (yet) appear in a coercion
- (see evTermCoercion), so the easy thing is to bind it to an Id.
+ (see evTermCoercion), so the easy thing is to bind it to a (coercion) Id.
+ This happens in GHC.Tc.Solver.Dict.solveEqualityDict.
So a Given has EvVar inside it rather than (as previously) an EvTerm.
@@ -2393,6 +2395,12 @@ wantedCtHasNoRewriters (WantedCt { ctev_rewriters = rws })
setWantedCtEvRewriters :: WantedCtEvidence -> RewriterSet -> WantedCtEvidence
setWantedCtEvRewriters ev rs = ev { ctev_rewriters = rs }
+ctEvRewriterSet :: CtEvidence -> RewriterSet
+-- Returns the set of holes (empty or singleton) for the evidence itself
+-- Note the difference from ctEvRewriters!
+ctEvRewriterSet (CtWanted (WantedCt { ctev_dest = HoleDest hole })) = unitRewriterSet hole
+ctEvRewriterSet _ = emptyRewriterSet
+
rewriterSetFromCts :: Bag Ct -> RewriterSet
-- Take a bag of Wanted equalities, and collect them as a RewriterSet
rewriterSetFromCts cts
@@ -2404,8 +2412,8 @@ rewriterSetFromCts cts
_ -> rw_set
ctEvExpr :: HasDebugCallStack => CtEvidence -> EvExpr
-ctEvExpr (CtWanted ev@(WantedCt { ctev_dest = HoleDest _ }))
- = Coercion $ ctEvCoercion (CtWanted ev)
+ctEvExpr (CtWanted (WantedCt { ctev_dest = HoleDest hole }))
+ = Coercion $ mkHoleCo hole
ctEvExpr ev = evId (ctEvEvId ev)
givenCtEvCoercion :: GivenCtEvidence -> TcCoercion
=====================================
testsuite/tests/perf/compiler/T8095.hs
=====================================
@@ -13,7 +13,9 @@ class Class a where
data Data (xs::a) = X | Y
deriving (Read,Show)
main = print test1
-instance (xs ~ Replicate1 ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Zero ))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) ()) => Class (Data xs) where
+-- instance (xs ~ Replicate1 ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Zero ))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) ()) => Class (Data xs) where
+instance (xs ~ Replicate1 ( Succ ( Succ ( Succ ( Succ ( Succ (Succ (Succ Zero ))))))) ()) => Class (Data xs) where
f X = Y
f Y = X
-test1 = f (X :: Data ( Replicate1 ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Zero ))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) () ))
+test1 = f (X :: Data ( Replicate1 ( Succ ( Succ ( Succ ( Succ (Succ (Succ (Succ Zero))))))) () ))
+-- test1 = f (X :: Data ( Replicate1 ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Zero ))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) () ))
=====================================
testsuite/tests/perf/compiler/T9872a.hs
=====================================
@@ -140,7 +140,8 @@ type Cube2 = Cube W G B W R R
type Cube3 = Cube G W R B R R
type Cube4 = Cube B R G G W W
-type Cubes = Cons Cube1 (Cons Cube2 (Cons Cube3 (Cons Cube4 Nil)))
+-- type Cubes = Cons Cube1 (Cons Cube2 (Cons Cube3 (Cons Cube4 Nil)))
+type Cubes = Cons Cube1 Nil
type family Compatible c d :: *
type instance Compatible (Cube u1 f1 r1 b1 l1 d1) (Cube u2 f2 r2 b2 l2 d2) =
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cf99a788eb64bf7289aa4fa0546a9ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cf99a788eb64bf7289aa4fa0546a9ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/ghc-cpp] 17 commits: rts/nonmoving: Fix comment spelling
by Alan Zimmerman (ļ¼ alanz) 15 Oct '25
by Alan Zimmerman (ļ¼ alanz) 15 Oct '25
15 Oct '25
Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC
Commits:
14281a22 by Ben Gamari at 2025-10-11T14:06:47-04:00
rts/nonmoving: Fix comment spelling
- - - - -
bedd38b0 by Ben Gamari at 2025-10-11T14:06:47-04:00
rts/nonmoving: Use atomic operations to update bd->flags
- - - - -
215d6841 by Ben Gamari at 2025-10-11T14:06:47-04:00
nonmoving: Use get_itbl instead of explicit loads
This is cleaner and also fixes unnecessary (and unsound) use of
`volatile`.
- - - - -
2c94aa3a by Ben Gamari at 2025-10-11T14:06:47-04:00
rts/Scav: Handle WHITEHOLEs in scavenge_one
`scavenge_one`, used to scavenge mutable list entries, may encounter
`WHITEHOLE`s when the non-moving GC is in use via two paths:
1. when an MVAR is being marked concurrently
2. when the object belongs to a chain of selectors being short-cutted.
Fixes #26204.
- - - - -
6bd8155c by Matthew Pickering at 2025-10-11T14:07:29-04:00
Add support for generating bytecode objects
This commit adds the `-fwrite-byte-code` option which makes GHC emit a
`.gbc` file which contains a serialised representation of bytecode.
The bytecode can be loaded by the compiler to avoid having to
reinterpret a module when using the bytecode interpreter (for example,
in GHCi).
There are also the new options:
* -gbcdir=<DIR>: Specify the directory to place the gbc files
* -gbcsuf=<suffix>: Specify the suffix for gbc files
The option `-fbyte-code-and-object-code` now implies
`-fwrite-byte-code`.
These performance tests fail due to https://github.com/haskell/directory/issues/204
-------------------------
Metric Increase:
MultiComponentModules
MultiLayerModules
MultiComponentModulesRecomp
MultiLayerModulesRecomp
MultiLayerModulesTH_Make
MultiLayerModulesTH_OneShot
T13701
-------------------------
The bytecode serialisation part was implemented by Cheng Shao
Co-authored-by: Cheng Shao <terrorjack(a)type.dance>
- - - - -
dc8f9599 by Matthew Pickering at 2025-10-11T14:07:30-04:00
Revert "Add a perf test for #26425"
This test has a large memory spike currently, which makes the test
sensitive, since if you allocate a little more or less, the precise
location where GC happens shifts and you observe a different part of the
spike.
Andreas told me to revert the patch for now, and he will add it back
when he fixes the memory spike.
This reverts commit 41bdb16fd083110a06507248f648c507a2feb4af.
- - - - -
e10dcd65 by Sven Tennie at 2025-10-12T10:24:56+00:00
T22859: Increase threadDelay for small machines
The previously used thread delay led to failures on my RISC-V test
setups.
- - - - -
d59ef6b6 by Hai / @BestYeen at 2025-10-14T21:51:14-04:00
Change Alex and Happy m4 scripts to display which version was found in the system, adapt small formatting details in Happy script to be more like the Alex script again.
- - - - -
c98abb6a by Hai / @BestYeen at 2025-10-14T21:52:08-04:00
Update occurrences of return to pure and add a sample for redefining :m to mean :main
- - - - -
70ee825a by Cheng Shao at 2025-10-14T21:52:50-04:00
testsuite: fix T3586 for non-SSE3 platforms
`T3586.hs` contains `-fvia-C -optc-msse3` which I think is a
best-effort basis to harvest the C compiler's auto vectorization
optimizations via the C backend back when the test was added. The
`-fvia-C` part is now a deprecated no-op because GHC can't fall back
to the C backend on a non-unregisterised build, and `-optc-msse3`
might actually cause the test to fail on non x86/x64 platforms, e.g.
recent builds of wasi-sdk would report `wasm32-wasi-clang: error:
unsupported option '-msse3' for target 'wasm32-unknown-wasi'`.
So this patch cleans up this historical cruft. `-fvia-C` is removed,
and `-optc-msse3` is only passed when cpuid contains `pni` (which
indicates support of SSE3).
- - - - -
4be32153 by Teo Camarasu at 2025-10-15T08:06:09-04:00
Add submodules for template-haskell-lift and template-haskell-quasiquoter
These two new boot libraries expose stable subsets of the
template-haskell interface.
This is an implemenation of the GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/696
Work towards #25262
- - - - -
0c00c9c3 by Ben Gamari at 2025-10-15T08:06:51-04:00
rts: Eliminate uses of implicit constant arrays
Folding of `const`-sized variable-length arrays to a constant-length
array is a gnu extension which clang complains about.
Closes #26502.
- - - - -
670e8dd1 by Alan Zimmerman at 2025-10-15T20:27:21+01:00
GHC-CPP: Initial implementation
Processes
#define FOO
#ifdef FOO
x = 1
#endif
Into
[ITcppIgnored [L loc ITcppDefine]
,ITcppIgnored [L loc ITcppIfdef]
,ITvarid "x"
,ITequal
,ITinteger (IL {il_text = SourceText "1", il_neg = False, il_value = 1})
,ITcppIgnored [L loc ITcppEndif]
,ITeof]
In time, ITcppIgnored will be pushed into a comment
Tidy up before re-visiting the continuation mechanic
Switch preprocessor to continuation passing style
Proof of concept, needs tidying up
Small cleanup
Get rid of some cruft
Summary: Patch:
Author: Alan Zimmerman <alan.zimm(a)gmail.com>
Date: 2025-10-12 16:23:56 +0100
Summary: Patch: rebase-and-tests-pass
Author: Alan Zimmerman <alan.zimm(a)gmail.com>
Date: 2025-10-12 14:19:04 +0100
Rebase, and all tests pass except whitespace for generated parser
Starting to integrate.
Need to get the pragma recognised and set
Make cppTokens extend to end of line, and process CPP comments
Remove unused ITcppDefined
Allow spaces between # and keyword for preprocessor directive
Process CPP continuation lines
They are emited as separate ITcppContinue tokens.
Perhaps the processing should be more like a comment, and keep on
going to the end.
BUT, the last line needs to be slurped as a whole.
Accumulate CPP continuations, process when ready
Can be simplified further, we only need one CPP token
Simplify Lexer interface. Only ITcpp
We transfer directive lines through it, then parse them from scratch
in the preprocessor.
Deal with directive on last line, with no trailing \n
Start parsing and processing the directives
Prepare for processing include files
Move PpState into PreProcess
And initParserState, initPragState too
Process nested include files
Also move PpState out of Lexer.x, so it is easy to evolve it in a ghci
session, loading utils/check-cpp/Main.hs
Split into separate files
Starting on expression parser.
But it hangs. Time for Text.Parsec.Expr
Start integrating the ghc-cpp work
From https://github.com/alanz/ghc-cpp
WIP
Fixup after rebase
WIP
Fixup after rebase, including all tests pass
Change pragma usage to GHC_CPP from GhcCPP
Some comments
Reformat
Delete unused file
Rename module Parse to ParsePP
Clarify naming in the parser
WIP. Switching to alex/happy to be able to work in-tree
Since Parsec is not available
Layering is now correct
- GHC lexer, emits CPP tokens
- accumulated in Preprocessor state
- Lexed by CPP lexer, CPP command extracted, tokens concated with
spaces (to get rid of token pasting via comments)
- if directive lexed and parsed by CPP lexer/parser, and evaluated
First example working
Loading Example1.hs into ghci, getting the right results
```
{-# LANGUAGE GHC_CPP #-}
module Example1 where
y = 3
x =
"hello"
"bye now"
foo = putStrLn x
```
Rebase, and all tests pass except whitespace for generated parser
info: patch template saved to `-`
More plumbing. Ready for testing tomorrow.
Proress. Renamed module State from Types
And at first blush it seems to handle preprocessor scopes properly.
Insert basic GHC version macros into parser
__GLASGOW_HASKELL__
__GLASGOW_HASKELL_FULL_VERSION__
__GLASGOW_HASKELL_PATCHLEVEL1__
__GLASGOW_HASKELL_PATCHLEVEL2__
Re-sync check-cpp for easy ghci work
Get rid of warnings
Rework macro processing, in check-cpp
Macros kept at the top level, looked up via name, multiple arity
versions per name can be stored
WIP. Can crack arguments for #define
Next step it to crack out args in an expansion
WIP on arg parsing.
Progress. Still screwing up nested parens.
Seems to work, but has redundant code
Remove redundant code
Reformat
Expand args, single pass
Still need to repeat until fixpoint
Fixed point expansion
Sync the playground to compiler
Working on dumping the GHC_CPP result
But We need to keep the BufSpan in a comment
Keep BufSpan in queued comments in GHC.Parser.Lexer
Getting close to being able to print the combined tokens
showing what is in and what is out
First implementation of dumpGhcCpp.
Example output
First dumps all macros in the state, then the source, showing which
lines are in and which are out
------------------------------
- |#define FOO(A,B) A + B
- |#define FOO(A,B,C) A + B + C
- |#if FOO(1,FOO(3,4)) == 8
- |-- a comment
|x = 1
- |#else
- |x = 5
- |#endif
Clean up a bit
Add -ddump-ghc-cpp option and a test based on it
Restore Lexer.x rules, we need them for continuation lines
Lexer.x: trying to sort out the span for continuations
- We need to match on \n at the end of the line
- We cannot simply back up for it
Inserts predefined macros. But does not dump properly
Because the cpp tokens have a trailing newline
Remove unnecessary LExer rules
We *need* the ones that explicitly match to the end of the line.
Generate correct span for ITcpp
Dump now works, except we do not render trailing `\` for continuation
lines. This is good enough for use in test output.
Reduce duplication in lexer
Tweaks
Insert min_version predefined macros into state
The mechanism now works. Still need to flesh out the full set.
Trying my alternative pragma syntax.
It works, but dumpGhcCpp is broken, I suspect from the ITcpp token
span update.
Pragma extraction now works, with both CPP and GHC_CPP
For the following
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 913
{-# LANGUAGE GHC_CPP #-}
#endif
We will enable GHC_CPP only
Remove some tracing
Fix test exes for changes
For GHC_CPP tests, normalise config-time-based macros
WIP
WIP again. What is wrong?
Revert to dynflags for normal not pragma lexing
Working on getting check-exact to work properly
Passes CppCommentPlacement test
Starting on exact printing with GHC_CPP
While overriding normal CPP
Correctly store CPP ignored tokens as comments
By populating the lexeme string in it, based on the bufpos
WIP
Simplifying
Update the active state logic
Work the new logic into the mainline code
Process `defined` operator
Manage lexer state while skipping tokens
There is very intricate layout-related state used when lexing. If a
CPP directive blanks out some tokens, store this state when the
blanking starts, and restore it when they are no longer being blanked.
Track the last token buffer index, for ITCppIgnored
We need to attach the source being skipped in an ITCppIgnored token.
We cannot simply use its BufSpan as an index into the underlying
StringBuffer as it counts unicode chars, not bytes.
So we update the lexer state to store the starting StringBuffer
location for the last token, and use the already-stored length to
extract the correct portion of the StringBuffer being parsed.
Process the ! operator in GHC_CPP expressions
Predefine a constant when GHC_CPP is being used.
WIP
Skip lines directly in the lexer when required
Properly manage location when accepting tokens again
Seems to be working now, for Example9
Remove tracing
Fix parsing '*' in block comments
Instead of replacing them with '-'
Keep the trailing backslash in a ITcpp token
Deal with only enabling one section of a group.
A group is an instance of a conditional introduced by
#if/#ifdef/#ifndef,
and ending at the final #endif, including intermediate #elsif sections
Replace remaining identifiers with 0 when evaluating
As per the spec
Snapshot before rebase
Skip non-processed lines starting with #
Export generateMacros so we can use it in ghc-exactprint
Fix rebase
Expose initParserStateWithMacrosString
Fix buggy lexer cppSkip
It was skipping all lines, not just ones prefixed by #
Fix evaluation of && to use the correct operator
Deal with closing #-} at the start of a line
Add the MIN_VERSION_GLASGOW_HASKELL predefined macro
Include MIN_VERSION_GLASGOW_HASKELL in GhcCpp01.stderr
Use a strict map for macro defines
Process TIdentifierLParen
Which only matters at the start of #define
Do not provide TIdentifierLParen paren twice
Handle whitespace between identifier and '(' for directive only
Expose some Lexer bitmap manipulation helpers
Deal with line pragmas as tokens
Blows up for dumpGhcCpp though
Allow strings delimited by a single quote too
Allow leading whitespace on cpp directives
As per https://timsong-cpp.github.io/cppwp/n4140/cpp#1
Implement GHC_CPP undef
Sort out expansion of no-arg macros, in a context with args
And make the expansion bottom out, in the case of recursion
Fix GhcCpp01 test
The LINE pragma stuff works in ghc-exactprint when specifically
setting flag to emit ITline_pragma tokens
Process comments in CPP directives
Correctly lex pragmas with finel #-} on a newline
Do not process CPP-style comments
Allow cpp-style comments when GHC_CPP enabled
Return other pragmas as cpp ignored when GHC_CPP active
Reorganise getOptionsFromFile for use in ghc-exactprint
We want to be able to inject predefined macro definitions into the
parser preprocessor state for when we do a hackage roundtrip.
Tweak testing
Only allow unknown cpp pragmas with # in left margin
Require # against left margin for all GHC_CPP directives
Fix CPP directives appearing in pragmas
And add a test for error reporting for missing `#if`
Starting to report GHC_CPP errors using GHC machinery
More GHC_CPP diagnostic results
WIP on converting error calls to GHC diagnostics in GHC_CPP
Working on CPP diagnostic reporting
Tweak some tests/lint warnings
More error reporting in Macro
Some cleanups
Some cleanup
GHC_CPP: Working on improving error reporting
Harvest some commonality
Use PPM as Maybe inside PP
Clean up a bit
Fix GhcCpp01 test
I think this needs to be made more robust. Likely by not dumping the
(pre-)defined macros.
info: patch template saved to `-`
info: patch template saved to `-`
- - - - -
b3280001 by Alan Zimmerman at 2025-10-15T21:25:09+01:00
Fix GhcCpp01 after rebase
- - - - -
847eea2c by Alan Zimmerman at 2025-10-15T21:25:09+01:00
GHC_CPP: delete utils/check-cpp
It is not needed
- - - - -
d05c9946 by Alan Zimmerman at 2025-10-15T21:25:09+01:00
GHC_CPP: remove #include processing
We do not support it
- - - - -
537a881b by Alan Zimmerman at 2025-10-15T21:25:09+01:00
GHC_CPP: move Eval.hs into GHC.Parser.PreProcess.Macro
- - - - -
135 changed files:
- .gitmodules
- compiler/GHC.hs
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/ByteCode/Breakpoints.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Cmm/Lexer.x
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/Parser/Monad.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Data/SmallArray.hs
- compiler/GHC/Driver/Backend.hs
- compiler/GHC/Driver/Backpack.hs
- + compiler/GHC/Driver/ByteCode.hs
- compiler/GHC/Driver/Config/Finder.hs
- compiler/GHC/Driver/Config/Parser.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Messager.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Parser.hs-boot
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/HaddockLex.x
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- + compiler/GHC/Parser/PreProcess.hs
- + compiler/GHC/Parser/PreProcess/Lexer.x
- + compiler/GHC/Parser/PreProcess/Macro.hs
- + compiler/GHC/Parser/PreProcess/ParsePP.hs
- + compiler/GHC/Parser/PreProcess/Parser.y
- + compiler/GHC/Parser/PreProcess/ParserM.hs
- + compiler/GHC/Parser/PreProcess/State.hs
- compiler/GHC/Parser/Utils.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/SysTools/Cpp.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/SptEntry.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
- docs/users_guide/debugging.rst
- docs/users_guide/ghci.rst
- docs/users_guide/phases.rst
- docs/users_guide/separate_compilation.rst
- ghc/GHCi/UI.hs
- hadrian/src/Packages.hs
- hadrian/src/Rules/SourceDist.hs
- hadrian/src/Settings/Default.hs
- libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- + libraries/template-haskell-lift
- + libraries/template-haskell-quasiquoter
- m4/fptools_alex.m4
- m4/fptools_happy.m4
- rts/Printer.c
- rts/include/rts/storage/Block.h
- rts/posix/OSMem.c
- rts/sm/NonMoving.c
- rts/sm/NonMovingMark.c
- rts/sm/Scav.c
- testsuite/driver/cpu_features.py
- testsuite/tests/bytecode/T24634/T24634a.stdout
- testsuite/tests/bytecode/T24634/T24634b.stdout
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/driver/T4437.hs
- + testsuite/tests/driver/bytecode-object/A.hs
- + testsuite/tests/driver/bytecode-object/BytecodeForeign.c
- + testsuite/tests/driver/bytecode-object/BytecodeForeign.hs
- + testsuite/tests/driver/bytecode-object/BytecodeMain.hs
- + testsuite/tests/driver/bytecode-object/BytecodeTest.hs
- + testsuite/tests/driver/bytecode-object/Makefile
- + testsuite/tests/driver/bytecode-object/all.T
- + testsuite/tests/driver/bytecode-object/bytecode_object12.stderr
- + testsuite/tests/driver/bytecode-object/bytecode_object13.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object14.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object15.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object16.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object17.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object18.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object19.script
- + testsuite/tests/driver/bytecode-object/bytecode_object19.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object25.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object4.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object5.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object6.stdout
- testsuite/tests/driver/fat-iface/T22405/T22405.stdout
- testsuite/tests/driver/fat-iface/T22405/T22405b.stdout
- testsuite/tests/driver/fat-iface/fat011.stderr
- testsuite/tests/ghc-api/T11579.hs
- + testsuite/tests/ghc-cpp/GhcCpp01.hs
- + testsuite/tests/ghc-cpp/GhcCpp01.stderr
- + testsuite/tests/ghc-cpp/GhcCpp02.hs
- + testsuite/tests/ghc-cpp/GhcCpp02.stderr
- + testsuite/tests/ghc-cpp/all.T
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/linters/notes.stdout
- testsuite/tests/linters/regex-linters/check-cpp.py
- testsuite/tests/perf/compiler/Makefile
- + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciWithBytecodeFiles.script
- ā testsuite/tests/perf/compiler/T26425.hs
- testsuite/tests/perf/compiler/all.T
- testsuite/tests/perf/should_run/T3586.hs
- testsuite/tests/perf/should_run/all.T
- + testsuite/tests/printer/CppCommentPlacement.hs
- testsuite/tests/rts/T22859.hs
- testsuite/tests/simplStg/should_compile/T22840.stderr
- utils/check-exact/Main.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Preprocess.hs
- utils/check-exact/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
- utils/haddock/haddock-api/src/Haddock/Parser.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac6bbca6d8dc44f5e725a3daa85a60ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac6bbca6d8dc44f5e725a3daa85a60ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Fix typos in haddock documentation for stack annotation API
by Marge Bot (ļ¼ marge-bot) 15 Oct '25
by Marge Bot (ļ¼ marge-bot) 15 Oct '25
15 Oct '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
e17dc695 by fendor at 2025-10-15T16:01:41-04:00
Fix typos in haddock documentation for stack annotation API
- - - - -
1 changed file:
- libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
Changes:
=====================================
libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
=====================================
@@ -17,6 +17,7 @@
-- the user to gain more control over what an IPE stack trace looks like.
--
-- The main advantages of stack frame annotations over other 'Backtraces':
+--
-- * Function signatures don't need to be modified to improve stack traces (e.g. via 'HasCallStack').
-- * Annotation are arbitrary user-defined datatypes, not just source locations.
-- * Stack frame annotations are always present and do not require recompilation (e.g. @-prof@ or @-g3@).
@@ -39,7 +40,7 @@ module GHC.Stack.Annotation.Experimental (
annotateCallStackIO,
-- * Push stack frame annotations in non-'IO' code.
--
- -- These variants all evaluate the code to be annotated to WHNF.
+ -- | These variants all evaluate the code to be annotated to WHNF.
-- Otherwise, the stack annotations will not be shown in stack traces,
-- as the computation is immediately "evaluated" to a thunk, popping the
-- annotation frames from the stack.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e17dc695bf1f5fc015c2a9ab8981ac6ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e17dc695bf1f5fc015c2a9ab8981ac6ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 2 commits: Refactor distinct constructor tables map construction
by Marge Bot (ļ¼ marge-bot) 15 Oct '25
by Marge Bot (ļ¼ marge-bot) 15 Oct '25
15 Oct '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
bf902a1d by Fendor at 2025-10-15T16:00:59-04:00
Refactor distinct constructor tables map construction
Adds `GHC.Types.Unique.FM.alterUFM_L`, `GHC.Types.Unique.DFM.alterUDFM_L`
`GHC.Data.Word64Map.alterLookup` to support fusion of distinct
constructor data insertion and lookup during the construction of the `DataCon`
map in `GHC.Stg.Debug.numberDataCon`.
Co-authored-by: Fendor <fendor(a)posteo.de>
Co-authored-by: Finley McIlwaine <finleymcilwaine(a)gmail.com>
- - - - -
b3585ba1 by Fendor at 2025-10-15T16:00:59-04:00
Allow per constructor refinement of distinct-constructor-tables
Introduce `-fno-distinct-constructor-tables`. A distinct constructor table
configuration is built from the combination of flags given, in order. For
example, to only generate distinct constructor tables for a few specific
constructors and no others, just pass
`-fdistinct-constructor-tables-only=C1,...,CN`.
This flag can be supplied multiple times to extend the set of
constructors to generate a distinct info table for.
You can disable generation of distinct constructor tables for all
configurations by passing `-fno-distinct-constructor-tables`.
The various configurations of these flags is included in the `DynFlags`
fingerprints, which should result in the expected recompilation logic.
Adds a test that checks for distinct tables for various given or omitted
constructors.
Updates CountDepsAst and CountDepsParser tests to account for new dependencies.
Fixes #23703
Co-authored-by: Fendor <fendor(a)posteo.de>
Co-authored-by: Finley McIlwaine <finleymcilwaine(a)gmail.com>
- - - - -
33 changed files:
- compiler/GHC/Data/Word64Map/Internal.hs
- compiler/GHC/Data/Word64Map/Lazy.hs
- compiler/GHC/Driver/Config/Stg/Debug.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Flags.hs
- compiler/GHC/Iface/Recomp/Flags.hs
- compiler/GHC/Stg/Debug.hs
- + compiler/GHC/Stg/Debug/Types.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/ghc.cabal.in
- docs/users_guide/debug-info.rst
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/rts/ipe/distinct-tables/Main.hs
- + testsuite/tests/rts/ipe/distinct-tables/Makefile
- + testsuite/tests/rts/ipe/distinct-tables/X.hs
- + testsuite/tests/rts/ipe/distinct-tables/all.T
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables01.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables02.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables03.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables04.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables05.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables06.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables07.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables08.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables09.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables10.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables11.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables12.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables13.stdout
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0c00c9c3b4e9b8515d4839f2c1d7d7ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0c00c9c3b4e9b8515d4839f2c1d7d7ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Add submodules for template-haskell-lift and template-haskell-quasiquoter
by Marge Bot (ļ¼ marge-bot) 15 Oct '25
by Marge Bot (ļ¼ marge-bot) 15 Oct '25
15 Oct '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
4be32153 by Teo Camarasu at 2025-10-15T08:06:09-04:00
Add submodules for template-haskell-lift and template-haskell-quasiquoter
These two new boot libraries expose stable subsets of the
template-haskell interface.
This is an implemenation of the GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/696
Work towards #25262
- - - - -
0c00c9c3 by Ben Gamari at 2025-10-15T08:06:51-04:00
rts: Eliminate uses of implicit constant arrays
Folding of `const`-sized variable-length arrays to a constant-length
array is a gnu extension which clang complains about.
Closes #26502.
- - - - -
c27cd0c6 by Fendor at 2025-10-15T09:40:36-04:00
Refactor distinct constructor tables map construction
Adds `GHC.Types.Unique.FM.alterUFM_L`, `GHC.Types.Unique.DFM.alterUDFM_L`
`GHC.Data.Word64Map.alterLookup` to support fusion of distinct
constructor data insertion and lookup during the construction of the `DataCon`
map in `GHC.Stg.Debug.numberDataCon`.
Co-authored-by: Fendor <fendor(a)posteo.de>
Co-authored-by: Finley McIlwaine <finleymcilwaine(a)gmail.com>
- - - - -
767a59e4 by Fendor at 2025-10-15T09:40:36-04:00
Allow per constructor refinement of distinct-constructor-tables
Introduce `-fno-distinct-constructor-tables`. A distinct constructor table
configuration is built from the combination of flags given, in order. For
example, to only generate distinct constructor tables for a few specific
constructors and no others, just pass
`-fdistinct-constructor-tables-only=C1,...,CN`.
This flag can be supplied multiple times to extend the set of
constructors to generate a distinct info table for.
You can disable generation of distinct constructor tables for all
configurations by passing `-fno-distinct-constructor-tables`.
The various configurations of these flags is included in the `DynFlags`
fingerprints, which should result in the expected recompilation logic.
Adds a test that checks for distinct tables for various given or omitted
constructors.
Updates CountDepsAst and CountDepsParser tests to account for new dependencies.
Fixes #23703
Co-authored-by: Fendor <fendor(a)posteo.de>
Co-authored-by: Finley McIlwaine <finleymcilwaine(a)gmail.com>
- - - - -
42ae5b19 by fendor at 2025-10-15T09:40:37-04:00
Fix typos in haddock documentation for stack annotation API
- - - - -
43 changed files:
- .gitmodules
- compiler/GHC/Data/Word64Map/Internal.hs
- compiler/GHC/Data/Word64Map/Lazy.hs
- compiler/GHC/Driver/Config/Stg/Debug.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Flags.hs
- compiler/GHC/Iface/Recomp/Flags.hs
- compiler/GHC/Stg/Debug.hs
- + compiler/GHC/Stg/Debug/Types.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/ghc.cabal.in
- docs/users_guide/debug-info.rst
- hadrian/src/Packages.hs
- hadrian/src/Settings/Default.hs
- libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- + libraries/template-haskell-lift
- + libraries/template-haskell-quasiquoter
- rts/Printer.c
- rts/posix/OSMem.c
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/rts/ipe/distinct-tables/Main.hs
- + testsuite/tests/rts/ipe/distinct-tables/Makefile
- + testsuite/tests/rts/ipe/distinct-tables/X.hs
- + testsuite/tests/rts/ipe/distinct-tables/all.T
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables01.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables02.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables03.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables04.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables05.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables06.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables07.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables08.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables09.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables10.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables11.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables12.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables13.stdout
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/21a826393e159ca60b00e5471c9030ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/21a826393e159ca60b00e5471c9030ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26166] WIP: fix all remaining wasm regressions for now
by Cheng Shao (ļ¼ TerrorJack) 15 Oct '25
by Cheng Shao (ļ¼ TerrorJack) 15 Oct '25
15 Oct '25
Cheng Shao pushed to branch wip/T26166 at Glasgow Haskell Compiler / GHC
Commits:
8f1564dc by Cheng Shao at 2025-10-15T15:14:16+02:00
WIP: fix all remaining wasm regressions for now
- - - - -
5 changed files:
- libraries/ghc-internal/cbits/RtsIface.c
- libraries/ghc-internal/include/RtsIfaceSymbols.h
- rts/RtsToHsIface.c
- rts/include/rts/RtsToHsIface.h
- rts/wasm/JSFFI.c
Changes:
=====================================
libraries/ghc-internal/cbits/RtsIface.c
=====================================
@@ -25,7 +25,7 @@ void init_ghc_hs_iface(void);
#define UNDEF_CLOSURE(module, symbol)
#define INFO_TBL(module, symbol) \
- extern StgInfoTable ghczminternal_##module##_##symbol;
+ extern const StgInfoTable ghczminternal_##module##_##symbol;
#include "RtsIfaceSymbols.h"
@@ -43,7 +43,7 @@ void init_ghc_hs_iface(void);
#define INFO_TBL(module, symbol) \
.symbol = &ghczminternal_##module##_##symbol,
-static const HsIface the_ghc_hs_iface = {
+static HsIface the_ghc_hs_iface = {
#include "RtsIfaceSymbols.h"
};
=====================================
libraries/ghc-internal/include/RtsIfaceSymbols.h
=====================================
@@ -60,7 +60,7 @@ CLOSURE(GHCziInternalziExceptionziType, overflowException_closure)
CLOSURE(GHCziInternalziCString, unpackCStringzh_closure)
INFO_TBL(GHCziInternalziCString, unpackCStringzh_info)
INFO_TBL(GHCziInternalziCString, unpackCStringUtf8zh_info)
-#if defined(wasm32_HOST_ARCH)
+#if defined(wasm32_HOST_ARCH) && defined(__PIC__)
CLOSURE(GHCziInternalziWasmziPrimziImports, raiseJSException_closure)
INFO_TBL(GHCziInternalziWasmziPrimziTypes, JSVal_con_info)
CLOSURE(GHCziInternalziWasmziPrimziConcziInternal, threadDelay_closure)
=====================================
rts/RtsToHsIface.c
=====================================
@@ -56,4 +56,4 @@
// This captures the symbols provided by ghc-internal which
// are needed by the RTS.
-const HsIface *ghc_hs_iface = NULL;
+HsIface *ghc_hs_iface = NULL;
=====================================
rts/include/rts/RtsToHsIface.h
=====================================
@@ -36,36 +36,36 @@ typedef struct {
StgClosure *runHandlersPtr_closure; // GHC.Internal.Conc.Signal.runHandlersPtr_closure
StgClosure *flushStdHandles_closure; // GHC.Internal.TopHandler.flushStdHandles_closure
StgClosure *runMainIO_closure; // GHC.Internal.TopHandler.runMainIO_closure
- StgInfoTable *Czh_con_info; // GHC.Internal.Types.Czh_con_info
- StgInfoTable *Izh_con_info; // GHC.Internal.Types.Izh_con_info
- StgInfoTable *Fzh_con_info; // GHC.Internal.Types.Fzh_con_info
- StgInfoTable *Dzh_con_info; // GHC.Internal.Types.Dzh_con_info
- StgInfoTable *Wzh_con_info; // GHC.Internal.Types.Wzh_con_info
+ const StgInfoTable *Czh_con_info; // GHC.Internal.Types.Czh_con_info
+ const StgInfoTable *Izh_con_info; // GHC.Internal.Types.Izh_con_info
+ const StgInfoTable *Fzh_con_info; // GHC.Internal.Types.Fzh_con_info
+ const StgInfoTable *Dzh_con_info; // GHC.Internal.Types.Dzh_con_info
+ const StgInfoTable *Wzh_con_info; // GHC.Internal.Types.Wzh_con_info
StgClosure *absentSumFieldError_closure; // GHC.Internal.Prim.Panic.absentSumFieldError_closure
StgClosure *runAllocationLimitHandler_closure; // GHC.Internal.AllocationLimitHandler.runAllocationLimitHandler_closure
- StgInfoTable *Ptr_con_info; // GHC.Internal.Ptr.Ptr_con_info
- StgInfoTable *FunPtr_con_info; // GHC.Internal.Ptr.FunPtr_con_info
- StgInfoTable *I8zh_con_info; // GHC.Internal.Int.I8zh_con_info
- StgInfoTable *I16zh_con_info; // GHC.Internal.Int.I16zh_con_info
- StgInfoTable *I32zh_con_info; // GHC.Internal.Int.I32zh_con_info
- StgInfoTable *I64zh_con_info; // GHC.Internal.Int.I64zh_con_info
- StgInfoTable *W8zh_con_info; // GHC.Internal.Word.W8zh_con_info
- StgInfoTable *W16zh_con_info; // GHC.Internal.Word.W16zh_con_info
- StgInfoTable *W32zh_con_info; // GHC.Internal.Word.W32zh_con_info
- StgInfoTable *W64zh_con_info; // GHC.Internal.Word.W64zh_con_info
- StgInfoTable *StablePtr_con_info; // GHC.Internal.Stable.StablePtr_con_info
+ const StgInfoTable *Ptr_con_info; // GHC.Internal.Ptr.Ptr_con_info
+ const StgInfoTable *FunPtr_con_info; // GHC.Internal.Ptr.FunPtr_con_info
+ const StgInfoTable *I8zh_con_info; // GHC.Internal.Int.I8zh_con_info
+ const StgInfoTable *I16zh_con_info; // GHC.Internal.Int.I16zh_con_info
+ const StgInfoTable *I32zh_con_info; // GHC.Internal.Int.I32zh_con_info
+ const StgInfoTable *I64zh_con_info; // GHC.Internal.Int.I64zh_con_info
+ const StgInfoTable *W8zh_con_info; // GHC.Internal.Word.W8zh_con_info
+ const StgInfoTable *W16zh_con_info; // GHC.Internal.Word.W16zh_con_info
+ const StgInfoTable *W32zh_con_info; // GHC.Internal.Word.W32zh_con_info
+ const StgInfoTable *W64zh_con_info; // GHC.Internal.Word.W64zh_con_info
+ const StgInfoTable *StablePtr_con_info; // GHC.Internal.Stable.StablePtr_con_info
StgClosure *StackSnapshot_closure; // GHC.Internal.Stack.CloneStack.StackSnapshot_closure
StgClosure *divZZeroException_closure; // GHC.Internal.Exception.Type.divZeroException_closure
StgClosure *underflowException_closure; // GHC.Internal.Exception.Type.underflowException_closure
StgClosure *overflowException_closure; // GHC.Internal.Exception.Type.overflowException_closure
StgClosure *unpackCStringzh_closure; // GHC.Internal.CString.unpackCStringzh_closure
- StgInfoTable *unpackCStringzh_info; // GHC.Internal.CString.unpackCStringzh_info
- StgInfoTable *unpackCStringUtf8zh_info; // GHC.Internal.CString.unpackCStringUtf8zh_info
+ const StgInfoTable *unpackCStringzh_info; // GHC.Internal.CString.unpackCStringzh_info
+ const StgInfoTable *unpackCStringUtf8zh_info; // GHC.Internal.CString.unpackCStringUtf8zh_info
#if defined(wasm32_HOST_ARCH)
StgClosure *raiseJSException_closure; // GHC.Internal.Wasm.Prim.Imports.raiseJSException_closure
- StgInfoTable *JSVal_con_info; // GHC.Internal.Wasm.Prim.Types.JSVal_con_info
+ const StgInfoTable *JSVal_con_info; // GHC.Internal.Wasm.Prim.Types.JSVal_con_info
StgClosure *threadDelay_closure; // GHC.Internal.Wasm.Prim.Conc.Internal.threadDelay_closure
#endif
} HsIface;
-extern const HsIface *ghc_hs_iface;
+extern HsIface *ghc_hs_iface;
=====================================
rts/wasm/JSFFI.c
=====================================
@@ -15,6 +15,22 @@ extern HsStablePtr rts_threadDelay_impl;
__attribute__((__weak__))
int __main_argc_argv(int argc, char *argv[]);
+#if !defined(__PIC__)
+void init_ghc_hs_iface(void);
+
+extern StgClosure ghczminternal_GHCziInternalziWasmziPrimziImports_raiseJSException_closure;
+extern const StgInfoTable ghczminternal_GHCziInternalziWasmziPrimziTypes_JSVal_con_info;
+extern StgClosure ghczminternal_GHCziInternalziWasmziPrimziConcziInternal_threadDelay_closure;
+
+__attribute__((constructor(100)))
+static void __init_ghc_hs_iface_jsffi(void) {
+ init_ghc_hs_iface();
+ ghc_hs_iface->raiseJSException_closure = &ghczminternal_GHCziInternalziWasmziPrimziImports_raiseJSException_closure;
+ ghc_hs_iface->JSVal_con_info = &ghczminternal_GHCziInternalziWasmziPrimziTypes_JSVal_con_info;
+ ghc_hs_iface->threadDelay_closure = &ghczminternal_GHCziInternalziWasmziPrimziConcziInternal_threadDelay_closure;
+}
+#endif
+
// Note [JSFFI initialization]
// ~~~~~~~~~~~~~~~~~~~~~~~~~~~
//
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f1564dcba343fd33fe50980015de07ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f1564dcba343fd33fe50980015de07ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/bomb_out] exprSize: Accumulate size as we go to allow early bomb out.
by Andreas Klebinger (ļ¼ AndreasK) 15 Oct '25
by Andreas Klebinger (ļ¼ AndreasK) 15 Oct '25
15 Oct '25
Andreas Klebinger pushed to branch wip/andreask/bomb_out at Glasgow Haskell Compiler / GHC
Commits:
e16e2882 by Andreas Klebinger at 2025-10-15T14:20:24+02:00
exprSize: Accumulate size as we go to allow early bomb out.
When dealing with branches in the AST we now accumulate
expr size across branches, rather than computing both
branches before adding them up.
This way we can abort early when it's clear an expression
is too large to be useful.
This fixes an issue I observed in #26425 where we sometimes
spent a significant amount of time computing unfolding sizes
in deeply nested but branching rhss.
Speedup is on the order of ~1%-4% depending on the program we
are compiling.
- - - - -
1 changed file:
- compiler/GHC/Core/Unfold.hs
Changes:
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE DataKinds #-}
+
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1994-1998
@@ -554,56 +556,69 @@ uncondInlineJoin bndrs body
go_arg (Var f) = Just $! f `notElem` bndrs
go_arg _ = Nothing
-
sizeExpr :: UnfoldingOpts
- -> Int -- Bomb out if it gets bigger than this
+ -> PlainSize -- Bomb out if it gets bigger than this
-> [Id] -- Arguments; we're interested in which of these
-- get case'd
-> CoreExpr
- -> ExprSize
+ -> ExprSize WithDiscount
-- Note [Computing the size of an expression]
-- Forcing bOMB_OUT_SIZE early prevents repeated
-- unboxing of the Int argument.
sizeExpr opts !bOMB_OUT_SIZE top_args expr
- = size_up expr
+ = case size_up 0 expr of
+ -- We skip the size check in some places, in exchange for checking it one last time here.
+ TooBig -> TooBig
+ size@(SizeIs size_n _arg_dc _scrut_dc)
+ | size_n > bOMB_OUT_SIZE -> TooBig
+ | otherwise -> size
where
- size_up (Cast e _) = size_up e
- size_up (Tick _ e) = size_up e
- size_up (Type _) = sizeZero -- Types cost nothing
- size_up (Coercion _) = sizeZero
- size_up (Lit lit) = sizeN (litSize lit)
- size_up (Var f) | isZeroBitId f = sizeZero
- -- Make sure we get constructor discounts even
- -- on nullary constructors
- | otherwise = size_up_call f [] 0
-
- size_up (App fun arg)
- | isTyCoArg arg = size_up fun
- | otherwise = size_up arg `addSizeNSD`
- size_up_app fun [arg] (if isZeroBitExpr arg then 1 else 0)
-
- size_up (Lam b e)
- | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up e `addSizeN` 10)
- | otherwise = size_up e
-
- size_up (Let (NonRec binder rhs) body)
- = size_up_rhs (binder, rhs) `addSizeNSD`
- size_up body `addSizeN`
- size_up_alloc binder
-
- size_up (Let (Rec pairs) body)
- = foldr (addSizeNSD . size_up_rhs)
- (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs))
- pairs
-
- size_up (Case e _ _ alts) = case nonEmpty alts of
- Nothing -> size_up e -- case e of {} never returns, so take size of scrutinee
+ -- (size_up s e) returns `s` plus the size of `e`
+ size_up :: PlainSize -> CoreExpr -> ExprSize WithDiscount
+ size_up acc_size _e | acc_size > bOMB_OUT_SIZE = TooBig
+ size_up acc_size (Cast e _) = size_up acc_size e
+ size_up acc_size (Tick _ e) = size_up acc_size e
+ size_up acc_size (Type _) = sizeND acc_size -- Types add no cost
+ size_up acc_size (Coercion _) = sizeND acc_size
+ size_up acc_size (Lit lit) = sizeND (acc_size + litSize lit)
+ size_up acc_size (Var f) | isZeroBitId f = sizeND acc_size
+ -- Make sure we get constructor discounts even
+ -- on nullary constructors
+ | otherwise = size_up_call acc_size emptyBag f [] 0
+
+ size_up acc_size (App fun arg)
+ | isTyCoArg arg = size_up acc_size fun
+ | otherwise = case size_up acc_size arg of
+ TooBig -> TooBig
+ SizeIs acc_size' acc_args' _d -> size_up_app acc_size' acc_args'
+ fun [arg] (if isZeroBitExpr arg then 1 else 0)
+
+ size_up acc_size (Lam b e)
+ | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up (acc_size+10) e)
+ | otherwise = size_up acc_size e
+
+ size_up acc_size (Let (NonRec binder rhs) body)
+ = case size_up_let acc_size emptyBag (binder, rhs) of
+ TooBig -> TooBig
+ SizeIs acc_size' acc_args' _d -> size_up acc_size' body `addSizeB` acc_args'
+
+ size_up acc_size (Let (Rec pairs) body)
+ = do_pairs acc_size emptyBag pairs
+ where
+ do_pairs acc_size acc_args [] = size_up acc_size body `addSizeB` acc_args
+ do_pairs acc_size acc_args (pair:pairs) =
+ case size_up_let acc_size acc_args pair of
+ TooBig -> TooBig
+ SizeIs acc_size' acc_args' _d -> do_pairs acc_size' acc_args' pairs
+
+ size_up acc_size (Case e _ _ alts) = case nonEmpty alts of
+ Nothing -> size_up acc_size e -- case e of {} never returns, so take size of scrutinee
Just alts
| Just v <- is_top_arg e -> -- We are scrutinising an argument variable
let
- alt_sizes = NE.map size_up_alt alts
+ alt_sizes = NE.map (size_up_alt acc_size) alts
-- alts_size tries to compute a good discount for
-- the case when we are scrutinising an argument variable
@@ -625,14 +640,15 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
alts_size tot_size _ = tot_size
in
- alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty
- (foldr1 maxSize alt_sizes)
+ sizeN acc_size `addSizeNSD` alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty
+ (foldr1 maxSize alt_sizes)
-- Good to inline if an arg is scrutinised, because
-- that may eliminate allocation in the caller
-- And it eliminates the case itself
- | otherwise -> size_up e `addSizeNSD`
- foldr (addAltSize . size_up_alt) case_size alts
+ | otherwise -> foldr (addAltSize . (size_up_alt acc_size))
+ (size_up (acc_size + case_size) e)
+ alts
where
is_top_arg (Var v) | v `elem` top_args = Just v
@@ -641,9 +657,10 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
is_top_arg _ = Nothing
where
+ case_size :: PlainSize
case_size
- | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10)
- | otherwise = sizeZero
+ | is_inline_scrut e, lengthAtMost alts 1 = (-10)
+ | otherwise = 0
-- Normally we don't charge for the case itself, but
-- we charge one per alternative (see size_up_alt,
-- below) to account for the cost of the info table
@@ -676,48 +693,64 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
| otherwise
= False
- size_up_rhs (bndr, rhs)
+ size_up_let :: PlainSize -> Bag (Id,Int) -> (Id, CoreExpr) -> ExprSize NoDiscount
+ size_up_let !acc_size acc_args (bndr, rhs)
| JoinPoint join_arity <- idJoinPointHood bndr
-- Skip arguments to join point
- , (_bndrs, body) <- collectNBinders join_arity rhs
- = size_up body
+ , (_bndrs, join_rhs) <- collectNBinders join_arity rhs
+ = (stripDiscounts $ size_up acc_size join_rhs) `addSizeB` acc_args
| otherwise
- = size_up rhs
+ = (stripDiscounts $ size_up (acc_size + size_up_alloc bndr) rhs) `addSizeB` acc_args
------------
-- size_up_app is used when there's ONE OR MORE value args
- size_up_app (App fun arg) args voids
- | isTyCoArg arg = size_up_app fun args voids
- | isZeroBitExpr arg = size_up_app fun (arg:args) (voids + 1)
- | otherwise = size_up arg `addSizeNSD`
- size_up_app fun (arg:args) voids
- size_up_app (Var fun) args voids = size_up_call fun args voids
- size_up_app (Tick _ expr) args voids = size_up_app expr args voids
- size_up_app (Cast expr _) args voids = size_up_app expr args voids
- size_up_app other args voids = size_up other `addSizeN`
- callSize (length args) voids
+ size_up_app :: PlainSize -> Bag (Id,Int) -> CoreExpr -> [CoreExpr] -> Int -> ExprSize WithDiscount
+ size_up_app !acc_size acc_args (App fun arg) args voids
+ | isTyCoArg arg = size_up_app acc_size acc_args fun args voids
+ | isZeroBitExpr arg = size_up_app acc_size acc_args fun (arg:args) (voids + 1)
+ | otherwise = case size_up acc_size arg of
+ TooBig -> TooBig
+ SizeIs acc_size' acc_args' _ ->
+ size_up_app acc_size' acc_args' fun (arg:args) voids
+ `addSizeB` acc_args
+ size_up_app acc_size acc_args (Var fun) args voids = size_up_call acc_size acc_args fun args voids
+ size_up_app acc_size acc_args (Tick _ expr) args voids = size_up_app acc_size acc_args expr args voids
+ size_up_app acc_size acc_args (Cast expr _) args voids = size_up_app acc_size acc_args expr args voids
+ size_up_app acc_size acc_args other args voids = size_up (acc_size + callSize (length args) voids) other `addSizeB` acc_args
+
-- if the lhs is not an App or a Var, or an invisible thing like a
-- Tick or Cast, then we should charge for a complete call plus the
-- size of the lhs itself.
------------
- size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize
- size_up_call fun val_args voids
- = case idDetails fun of
- FCallId _ -> sizeN (callSize (length val_args) voids)
- DataConWorkId dc -> conSize dc (length val_args)
- PrimOpId op _ -> primOpSize op (length val_args)
- ClassOpId cls _ -> classOpSize opts cls top_args val_args
- _ | fun `hasKey` buildIdKey -> buildSize
- | fun `hasKey` augmentIdKey -> augmentSize
- | otherwise -> funSize opts top_args fun (length val_args) voids
+ size_up_call :: PlainSize -> Bag (Id,Int) -> Id -> [CoreExpr] -> Int -> ExprSize WithDiscount
+ size_up_call !acc_size acc_args fun val_args voids
+ = let !n_args = length val_args
+ call_size = case idDetails fun of
+ FCallId _ -> withDiscount $ sizeN (callSize n_args voids)
+ DataConWorkId dc -> conSize dc n_args
+ PrimOpId op _ -> sizeND $ primOpSize op n_args
+ ClassOpId cls _ -> withDiscount $ classOpSize opts cls top_args val_args
+ _ | fun `hasKey` buildIdKey -> buildSize
+ | fun `hasKey` augmentIdKey -> augmentSize
+ | otherwise -> funSize opts top_args fun n_args voids
+ in mkSizeNoDiscount bOMB_OUT_SIZE acc_size acc_args `addSizeNSD` call_size
------------
- size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10
+ -- size_up_alt returns only the alternatives size, not counting the accumulated
+ -- size passed in unless we reach TooBig. This is to facility better discount
+ -- calculation based on the size of only the alternative.
+ -- size_up_alt acc_size acc_args = TooBig
+ size_up_alt acc_size (Alt _con _bndrs rhs) =
+ size_up acc_size rhs
+ -- Why add and then subtract s?
+ -- If the expression large enough this will ensure we bomb out early.
+ `addSizeND` (10 -acc_size)
+
-- Don't charge for args, so that wrappers look cheap
-- (See comments about wrappers with Case)
--
- -- IMPORTANT: *do* charge 1 for the alternative, else we
+ -- IMPORTANT: *do* charge 10 for the alternative, else we
-- find that giant case nests are treated as practically free
-- A good example is Foreign.C.Error.errnoToIOError
@@ -734,26 +767,40 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
------------
-- These addSize things have to be here because
-- I don't want to give them bOMB_OUT_SIZE as an argument
- addSizeN TooBig _ = TooBig
- addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n + m) xs d
+ addSizeND :: ExprSize WithDiscount -> Int -> ExprSize WithDiscount
+ addSizeND TooBig _ = TooBig
+ addSizeND (SizeIs n xs d) m = mkSizeDiscount bOMB_OUT_SIZE (n + m) xs d
+ addSizeB :: ExprSize a -> Bag (Id,Int) -> ExprSize a
+ addSizeB TooBig _ = TooBig
+ addSizeB (SizeIs sz bg1 dc) bg2 = SizeIs sz (bg1 `unionBags` bg2) dc
-- addAltSize is used to add the sizes of case alternatives
addAltSize TooBig _ = TooBig
addAltSize _ TooBig = TooBig
addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
- = mkSizeIs bOMB_OUT_SIZE (n1 + n2)
+ = mkSizeDiscount bOMB_OUT_SIZE (n1 + n2)
(xs `unionBags` ys)
(d1 + d2) -- Note [addAltSize result discounts]
-- This variant ignores the result discount from its LEFT argument
-- It's used when the second argument isn't part of the result
+ addSizeNSD :: ExprSize NoDiscount -> ExprSize WithDiscount -> ExprSize WithDiscount
addSizeNSD TooBig _ = TooBig
addSizeNSD _ TooBig = TooBig
addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2)
- = mkSizeIs bOMB_OUT_SIZE (n1 + n2)
+ = mkSizeDiscount bOMB_OUT_SIZE (n1 + n2)
(xs `unionBags` ys)
d2 -- Ignore d1
+ -- Throw away the discount for scrutinizing the expression.
+ -- Used for things like `let x = rhs in body` where we only consider
+ -- this benefit for the body.
+ -- Why? `x` is visible to `body` either way, so it really should not
+ -- affect our inlining decision either way.
+ stripDiscounts :: ExprSize a -> ExprSize NoDiscount
+ stripDiscounts TooBig = TooBig
+ stripDiscounts (SizeIs n xs _) = (SizeIs n xs 0)
+
-- don't count expressions such as State# RealWorld
-- exclude join points, because they can be rep-polymorphic
-- and typePrimRep will crash
@@ -764,7 +811,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
isZeroBitExpr _ = False
-- | Finds a nominal size of a string literal.
-litSize :: Literal -> Int
+litSize :: Literal -> PlainSize
-- Used by GHC.Core.Unfold.sizeExpr
litSize (LitNumber LitNumBigNat _) = 100
litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4)
@@ -775,7 +822,7 @@ litSize _other = 0 -- Must match size of nullary constructors
-- Key point: if x |-> 4, then x must inline unconditionally
-- (eg via case binding)
-classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize
+classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize NoDiscount
-- See Note [Conlike is interesting]
classOpSize opts cls top_args args
| isUnaryClass cls
@@ -798,7 +845,7 @@ classOpSize opts cls top_args args
callSize
:: Int -- ^ number of value args
-> Int -- ^ number of value args that are void
- -> Int
+ -> PlainSize
callSize n_val_args voids = 10 * (1 + n_val_args - voids)
-- The 1+ is for the function itself
-- Add 1 for each non-trivial arg;
@@ -808,7 +855,7 @@ callSize n_val_args voids = 10 * (1 + n_val_args - voids)
jumpSize
:: Int -- ^ number of value args
-> Int -- ^ number of value args that are void
- -> Int
+ -> PlainSize
jumpSize _n_val_args _voids = 0 -- Jumps are small, and we don't want penalise them
-- Old version:
@@ -818,7 +865,7 @@ jumpSize _n_val_args _voids = 0 -- Jumps are small, and we don't want penalise
-- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a
-- better solution?
-funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize
+funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize WithDiscount
-- Size for function calls where the function is not a constructor or primops
-- Note [Function applications]
funSize opts top_args fun n_val_args voids
@@ -844,14 +891,14 @@ funSize opts top_args fun n_val_args voids
-- If the function is partially applied, show a result discount
-- XXX maybe behave like ConSize for eval'd variable
-conSize :: DataCon -> Int -> ExprSize
+conSize :: DataCon -> Int -> ExprSize WithDiscount
conSize dc n_val_args
| n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables
-- See Note [Unboxed tuple size and result discount]
| isUnboxedTupleDataCon dc = SizeIs 0 emptyBag 10
- | isUnaryClassDataCon dc = sizeZero
+ | isUnaryClassDataCon dc = withDiscount sizeZero
-- See Note [Constructor size and result discount]
| otherwise = SizeIs 10 emptyBag 10
@@ -948,16 +995,16 @@ that mention a literal Integer, because the float-out pass will float
all those constants to top level.
-}
-primOpSize :: PrimOp -> Int -> ExprSize
+primOpSize :: PrimOp -> Int -> PlainSize
primOpSize op n_val_args
= if primOpOutOfLine op
- then sizeN (op_size + n_val_args)
- else sizeN op_size
+ then (op_size + n_val_args)
+ else op_size
where
op_size = primOpCodeSize op
-buildSize :: ExprSize
+buildSize :: ExprSize WithDiscount
buildSize = SizeIs 0 emptyBag 40
-- We really want to inline applications of build
-- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
@@ -966,13 +1013,13 @@ buildSize = SizeIs 0 emptyBag 40
-- build is saturated (it usually is). The "-2" discounts for the \c n,
-- The "4" is rather arbitrary.
-augmentSize :: ExprSize
+augmentSize :: ExprSize WithDiscount
augmentSize = SizeIs 0 emptyBag 40
-- Ditto (augment t (\cn -> e) ys) should cost only the cost of
-- e plus ys. The -2 accounts for the \cn
-- When we return a lambda, give a discount if it's used (applied)
-lamScrutDiscount :: UnfoldingOpts -> ExprSize -> ExprSize
+lamScrutDiscount :: UnfoldingOpts -> ExprSize a -> ExprSize WithDiscount
lamScrutDiscount opts (SizeIs n vs _) = SizeIs n vs (unfoldingFunAppDiscount opts)
lamScrutDiscount _ TooBig = TooBig
@@ -1045,18 +1092,27 @@ In a function application (f a b)
Code for manipulating sizes
-}
+-- | Does an ExprSize include an evaluation Discount?
+data HasDiscount = NoDiscount | WithDiscount deriving (Eq)
+
+type PlainSize = Int -- Things that have a size, but not argument discount, nor scrut discount
+
-- | The size of a candidate expression for unfolding
-data ExprSize
+--
+-- We don't use a separate constructor without a discount field as the
+-- re-allocation here as the resulting re-allocation when converting
+-- between them outweights any benefit.
+data ExprSize (hasDiscount :: HasDiscount)
= TooBig
- | SizeIs { _es_size_is :: {-# UNPACK #-} !Int -- ^ Size found
+ | SizeIs { _es_size_is :: {-# UNPACK #-} !PlainSize -- ^ Size found
, _es_args :: !(Bag (Id,Int))
-- ^ Arguments cased herein, and discount for each such
, _es_discount :: {-# UNPACK #-} !Int
-- ^ Size to subtract if result is scrutinised by a case
- -- expression
+ -- expression. Must be zero if `hasDiscount == NoDiscount`
}
-instance Outputable ExprSize where
+instance Outputable (ExprSize a) where
ppr TooBig = text "TooBig"
ppr (SizeIs a _ c) = brackets (int a <+> int c)
@@ -1065,18 +1121,28 @@ instance Outputable ExprSize where
-- tup = (a_1, ..., a_99)
-- x = case tup of ...
--
-mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize
-mkSizeIs max n xs d | (n - d) > max = TooBig
- | otherwise = SizeIs n xs d
+mkSizeDiscount :: Int -> PlainSize -> Bag (Id, Int) -> Int -> ExprSize WithDiscount
+mkSizeDiscount max n xs d | (n - d) > max = TooBig
+ | otherwise = SizeIs n xs d
+
+mkSizeNoDiscount :: Int -> PlainSize -> Bag (Id, Int) -> ExprSize NoDiscount
+mkSizeNoDiscount max n xs | n > max = TooBig
+ | otherwise = SizeIs n xs 0
-maxSize :: ExprSize -> ExprSize -> ExprSize
+maxSize :: ExprSize a -> ExprSize a -> ExprSize a
maxSize TooBig _ = TooBig
maxSize _ TooBig = TooBig
maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2 = s1
| otherwise = s2
+withDiscount :: ExprSize NoDiscount -> ExprSize WithDiscount
+withDiscount s = case s of
+ TooBig -> TooBig
+ SizeIs x1 x2 x3 -> SizeIs x1 x2 x3
-sizeZero :: ExprSize
-sizeN :: Int -> ExprSize
+sizeZero :: ExprSize NoDiscount
+sizeN :: PlainSize -> ExprSize NoDiscount
+sizeND :: PlainSize -> ExprSize WithDiscount
sizeZero = SizeIs 0 emptyBag 0
sizeN n = SizeIs n emptyBag 0
+sizeND = withDiscount . sizeN
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e16e2882214cea1f57ec7289047faaeā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e16e2882214cea1f57ec7289047faaeā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] rts: Eliminate uses of implicit constant arrays
by Marge Bot (ļ¼ marge-bot) 15 Oct '25
by Marge Bot (ļ¼ marge-bot) 15 Oct '25
15 Oct '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
0c00c9c3 by Ben Gamari at 2025-10-15T08:06:51-04:00
rts: Eliminate uses of implicit constant arrays
Folding of `const`-sized variable-length arrays to a constant-length
array is a gnu extension which clang complains about.
Closes #26502.
- - - - -
2 changed files:
- rts/Printer.c
- rts/posix/OSMem.c
Changes:
=====================================
rts/Printer.c
=====================================
@@ -1033,8 +1033,8 @@ findPtr(P_ p, int follow)
{
uint32_t g, n;
bdescr *bd;
- const int arr_size = 1024;
- StgPtr arr[arr_size];
+#define ARR_SIZE 1024
+ StgPtr arr[ARR_SIZE];
int i = 0;
searched = 0;
@@ -1044,24 +1044,24 @@ findPtr(P_ p, int follow)
// just before a block is used.
for (n = 0; n < getNumCapabilities(); n++) {
bd = nurseries[i].blocks;
- i = findPtrBlocks(p,bd,arr,arr_size,i);
- if (i >= arr_size) return;
+ i = findPtrBlocks(p,bd,arr,ARR_SIZE,i);
+ if (i >= ARR_SIZE) return;
}
#endif
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
bd = generations[g].blocks;
- i = findPtrBlocks(p,bd,arr,arr_size,i);
+ i = findPtrBlocks(p,bd,arr,ARR_SIZE,i);
bd = generations[g].large_objects;
- i = findPtrBlocks(p,bd,arr,arr_size,i);
- if (i >= arr_size) return;
+ i = findPtrBlocks(p,bd,arr,ARR_SIZE,i);
+ if (i >= ARR_SIZE) return;
for (n = 0; n < getNumCapabilities(); n++) {
i = findPtrBlocks(p, gc_threads[n]->gens[g].part_list,
- arr, arr_size, i);
+ arr, ARR_SIZE, i);
i = findPtrBlocks(p, gc_threads[n]->gens[g].todo_bd,
- arr, arr_size, i);
+ arr, ARR_SIZE, i);
}
- if (i >= arr_size) return;
+ if (i >= ARR_SIZE) return;
}
if (follow && i == 1) {
debugBelch("-->\n");
=====================================
rts/posix/OSMem.c
=====================================
@@ -585,7 +585,7 @@ void *osReserveHeapMemory(void *startAddressPtr, W_ *len)
}
#endif
- const int MAX_ATTEMPTS = 256;
+#define MAX_ATTEMPTS 256
void *bad_allocs[MAX_ATTEMPTS];
size_t bad_alloc_lens[MAX_ATTEMPTS];
memset(bad_allocs, 0, sizeof(void*) * MAX_ATTEMPTS);
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c00c9c3b4e9b8515d4839f2c1d7d77ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c00c9c3b4e9b8515d4839f2c1d7d77ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Add submodules for template-haskell-lift and template-haskell-quasiquoter
by Marge Bot (ļ¼ marge-bot) 15 Oct '25
by Marge Bot (ļ¼ marge-bot) 15 Oct '25
15 Oct '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
4be32153 by Teo Camarasu at 2025-10-15T08:06:09-04:00
Add submodules for template-haskell-lift and template-haskell-quasiquoter
These two new boot libraries expose stable subsets of the
template-haskell interface.
This is an implemenation of the GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/696
Work towards #25262
- - - - -
7 changed files:
- .gitmodules
- hadrian/src/Packages.hs
- hadrian/src/Settings/Default.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- + libraries/template-haskell-lift
- + libraries/template-haskell-quasiquoter
Changes:
=====================================
.gitmodules
=====================================
@@ -118,3 +118,9 @@
[submodule "libraries/file-io"]
path = libraries/file-io
url = https://gitlab.haskell.org/ghc/packages/file-io.git
+[submodule "libraries/template-haskell-lift"]
+ path = libraries/template-haskell-lift
+ url = https://gitlab.haskell.org/ghc/template-haskell-lift.git
+[submodule "libraries/template-haskell-quasiquoter"]
+ path = libraries/template-haskell-quasiquoter
+ url = https://gitlab.haskell.org/ghc/template-haskell-quasiquoter.git
=====================================
hadrian/src/Packages.hs
=====================================
@@ -9,7 +9,7 @@ module Packages (
ghcToolchain, ghcToolchainBin, haddockApi, haddockLibrary, haddock, haskeline,
hsc2hs, hp2ps, hpc, hpcBin, integerGmp, iserv, iservProxy,
libffi, mtl, osString, parsec, pretty, primitive, process, remoteIserv, rts,
- runGhc, semaphoreCompat, stm, templateHaskell, terminfo, text, time, timeout,
+ runGhc, semaphoreCompat, stm, templateHaskell, thLift, thQuasiquoter, terminfo, text, time, timeout,
transformers, unlit, unix, win32, xhtml,
lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
ghcPackages, isGhcPackage,
@@ -39,7 +39,7 @@ ghcPackages =
, ghcCompact, ghcConfig, ghcExperimental, ghcHeap, ghcInternal, ghci, ghciWrapper, ghcPkg, ghcPrim
, ghcToolchain, ghcToolchainBin, haddockApi, haddockLibrary, haddock, haskeline, hsc2hs
, hp2ps, hpc, hpcBin, integerGmp, iserv, libffi, mtl, osString
- , parsec, pretty, process, rts, runGhc, stm, semaphoreCompat, templateHaskell
+ , parsec, pretty, process, rts, runGhc, stm, semaphoreCompat, templateHaskell, thLift, thQuasiquoter
, terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio
, timeout
, lintersCommon
@@ -56,7 +56,7 @@ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, count
ghcCompact, ghcConfig, ghcExperimental, ghcHeap, ghci, ghcInternal, ghciWrapper, ghcPkg, ghcPrim,
ghcToolchain, ghcToolchainBin, haddockLibrary, haddockApi, haddock, haskeline, hsc2hs,
hp2ps, hpc, hpcBin, integerGmp, iserv, iservProxy, remoteIserv, libffi, mtl,
- osString, parsec, pretty, primitive, process, rts, runGhc, semaphoreCompat, stm, templateHaskell,
+ osString, parsec, pretty, primitive, process, rts, runGhc, semaphoreCompat, stm, templateHaskell, thLift, thQuasiquoter,
terminfo, text, time, transformers, unlit, unix, win32, xhtml,
timeout,
lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
@@ -124,6 +124,8 @@ runGhc = util "runghc"
semaphoreCompat = lib "semaphore-compat"
stm = lib "stm"
templateHaskell = lib "template-haskell"
+thLift = lib "template-haskell-lift"
+thQuasiquoter = lib "template-haskell-quasiquoter"
terminfo = lib "terminfo"
text = lib "text"
time = lib "time"
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -106,6 +106,8 @@ stage0Packages = do
, runGhc
, semaphoreCompat -- depends on
, time -- depends on win32
+ , thLift -- new library not yet present for boot compilers
+ , thQuasiquoter -- new library not yet present for boot compilers
, unlit
, if windowsHost then win32 else unix
-- We must use the in-tree `Win32` as the version
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
=====================================
@@ -20,7 +20,7 @@
-- | This module gives the definition of the 'Lift' class.
--
-- This is an internal module.
--- Please import "Language.Haskell.TH" or "Language.Haskell.TH.Syntax" instead!
+-- Please import "Language.Haskell.TH.Lift", "Language.Haskell.TH" or "Language.Haskell.TH.Syntax" instead!
module GHC.Internal.TH.Lift
( Lift(..)
@@ -71,6 +71,9 @@ import GHC.Internal.ForeignPtr
-- > deriving Lift
--
-- Representation-polymorphic since /template-haskell-2.16.0.0/.
+--
+-- This is exposed both from the @template-haskell-lift@ and @template-haskell@ packages.
+-- Consider importing it from the more stable @template-haskell-lift@ if you don't need the full breadth of the @template-haskell@ interface.
class Lift (t :: TYPE r) where
-- | Turn a value into a Template Haskell expression, suitable for use in
-- a splice.
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
=====================================
@@ -31,6 +31,9 @@ import GHC.Internal.Base hiding (Type)
-- @QuasiQuoter@ that is only intended to be used in certain splice
-- contexts, the unused fields should just 'fail'. This is most easily
-- accomplished using 'namedefaultQuasiQuoter' or 'defaultQuasiQuoter'.
+--
+-- This is exposed both from the @template-haskell-quasiquoter@ and @template-haskell@ packages.
+-- Consider importing it from the more stable @template-haskell-quasiquoter@ if you don't need the full breadth of the @template-haskell@ interface.
data QuasiQuoter = QuasiQuoter {
-- | Quasi-quoter for expressions, invoked by quotes like @lhs = $[q|...]@
quoteExp :: String -> Q Exp,
=====================================
libraries/template-haskell-lift
=====================================
@@ -0,0 +1 @@
+Subproject commit e0b2a7eefcd1b7247af63ab4a691d3161eada284
=====================================
libraries/template-haskell-quasiquoter
=====================================
@@ -0,0 +1 @@
+Subproject commit a47506eca032b139d9779fb8210d408c81d3fbd6
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4be32153febff94f9c89f7f74971da3ā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4be32153febff94f9c89f7f74971da3ā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/occ_anal_tuning] 7 commits: rts/nonmoving: Fix comment spelling
by Andreas Klebinger (ļ¼ AndreasK) 15 Oct '25
by Andreas Klebinger (ļ¼ AndreasK) 15 Oct '25
15 Oct '25
Andreas Klebinger pushed to branch wip/andreask/occ_anal_tuning at Glasgow Haskell Compiler / GHC
Commits:
14281a22 by Ben Gamari at 2025-10-11T14:06:47-04:00
rts/nonmoving: Fix comment spelling
- - - - -
bedd38b0 by Ben Gamari at 2025-10-11T14:06:47-04:00
rts/nonmoving: Use atomic operations to update bd->flags
- - - - -
215d6841 by Ben Gamari at 2025-10-11T14:06:47-04:00
nonmoving: Use get_itbl instead of explicit loads
This is cleaner and also fixes unnecessary (and unsound) use of
`volatile`.
- - - - -
2c94aa3a by Ben Gamari at 2025-10-11T14:06:47-04:00
rts/Scav: Handle WHITEHOLEs in scavenge_one
`scavenge_one`, used to scavenge mutable list entries, may encounter
`WHITEHOLE`s when the non-moving GC is in use via two paths:
1. when an MVAR is being marked concurrently
2. when the object belongs to a chain of selectors being short-cutted.
Fixes #26204.
- - - - -
6bd8155c by Matthew Pickering at 2025-10-11T14:07:29-04:00
Add support for generating bytecode objects
This commit adds the `-fwrite-byte-code` option which makes GHC emit a
`.gbc` file which contains a serialised representation of bytecode.
The bytecode can be loaded by the compiler to avoid having to
reinterpret a module when using the bytecode interpreter (for example,
in GHCi).
There are also the new options:
* -gbcdir=<DIR>: Specify the directory to place the gbc files
* -gbcsuf=<suffix>: Specify the suffix for gbc files
The option `-fbyte-code-and-object-code` now implies
`-fwrite-byte-code`.
These performance tests fail due to https://github.com/haskell/directory/issues/204
-------------------------
Metric Increase:
MultiComponentModules
MultiLayerModules
MultiComponentModulesRecomp
MultiLayerModulesRecomp
MultiLayerModulesTH_Make
MultiLayerModulesTH_OneShot
T13701
-------------------------
The bytecode serialisation part was implemented by Cheng Shao
Co-authored-by: Cheng Shao <terrorjack(a)type.dance>
- - - - -
dc8f9599 by Matthew Pickering at 2025-10-11T14:07:30-04:00
Revert "Add a perf test for #26425"
This test has a large memory spike currently, which makes the test
sensitive, since if you allocate a little more or less, the precise
location where GC happens shifts and you observe a different part of the
spike.
Andreas told me to revert the patch for now, and he will add it back
when he fixes the memory spike.
This reverts commit 41bdb16fd083110a06507248f648c507a2feb4af.
- - - - -
297e4e90 by Andreas Klebinger at 2025-10-14T14:54:12+02:00
OccAnal: Be stricter.
* When combining usageDetails.
* When constructing core expressions.
In combineUsageDetails when combining the underlying adds we compute a
new `LocalOcc` for each entry by combining the two existing ones.
Rather than wait for those entries to be forced down the road we now
force them immediately. Speeding up T26425 by about 10% with little
effect on the common case.
We also force CoreExprs we construct in order to prevent them from
captuing the OccAnal Env massively reducing residency in some cases.
For T26425 residency went down by a factor of ~10x.
-------------------------
Metric Decrease:
T26425
-------------------------
- - - - -
75 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/ByteCode/Breakpoints.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Data/Graph/UnVar.hs
- compiler/GHC/Data/SmallArray.hs
- compiler/GHC/Driver/Backend.hs
- compiler/GHC/Driver/Backpack.hs
- + compiler/GHC/Driver/ByteCode.hs
- compiler/GHC/Driver/Config/Finder.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Messager.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Types/SptEntry.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Var/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- compiler/GHC/Utils/Binary.hs
- compiler/ghc.cabal.in
- docs/users_guide/phases.rst
- docs/users_guide/separate_compilation.rst
- rts/include/rts/storage/Block.h
- rts/sm/NonMoving.c
- rts/sm/NonMovingMark.c
- rts/sm/Scav.c
- testsuite/tests/bytecode/T24634/T24634a.stdout
- testsuite/tests/bytecode/T24634/T24634b.stdout
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/driver/bytecode-object/A.hs
- + testsuite/tests/driver/bytecode-object/BytecodeForeign.c
- + testsuite/tests/driver/bytecode-object/BytecodeForeign.hs
- + testsuite/tests/driver/bytecode-object/BytecodeMain.hs
- + testsuite/tests/driver/bytecode-object/BytecodeTest.hs
- + testsuite/tests/driver/bytecode-object/Makefile
- + testsuite/tests/driver/bytecode-object/all.T
- + testsuite/tests/driver/bytecode-object/bytecode_object12.stderr
- + testsuite/tests/driver/bytecode-object/bytecode_object13.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object14.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object15.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object16.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object17.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object18.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object19.script
- + testsuite/tests/driver/bytecode-object/bytecode_object19.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object25.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object4.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object5.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object6.stdout
- testsuite/tests/driver/fat-iface/T22405/T22405.stdout
- testsuite/tests/driver/fat-iface/T22405/T22405b.stdout
- testsuite/tests/driver/fat-iface/fat011.stderr
- testsuite/tests/perf/compiler/Makefile
- + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciWithBytecodeFiles.script
- ā testsuite/tests/perf/compiler/T26425.hs
- testsuite/tests/perf/compiler/all.T
- testsuite/tests/simplStg/should_compile/T22840.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e2e19a7d28d27d3e1208c6335f79eā¦
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e2e19a7d28d27d3e1208c6335f79eā¦
You're receiving this email because of your account on gitlab.haskell.org.
1
0