April 2025 - ghc-commits

[Git][ghc/ghc][wip/T25440] Improve comments following dicsussion with Richard
by Simon Peyton Jones (＠simonpj) 21 Apr '25

21 Apr '25

Simon Peyton Jones pushed to branch wip/T25440 at Glasgow Haskell Compiler / GHC Commits: 4d2a3dbc by Simon Peyton Jones at 2025-04-21T23:42:54+01:00 Improve comments following dicsussion with Richard And materially change canEqLHSHetero, so that it puts the constraint directly in the Irreds - - - - - 5 changed files: - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Zonk/TcType.hs Changes: ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -1604,7 +1604,7 @@ canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2) -> TcType -> TcType -- xi2 -> TcKind -- ki2 -> TcS (StopOrContinue (Either IrredCt EqCt)) -canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 +canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 _ps_xi2 ki2 -- See Note [Equalities with incompatible kinds] -- See Note [Kind Equality Orientation] @@ -1625,6 +1625,9 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 -- Otherwise we might put something in the inert set that isn't inert then startAgainWith (mkNonCanonical ev) else + assertPpr (not (isEmptyRewriterSet rewriters)) (ppr ev) $ + -- The rewriter set won't be empty because the two kinds differ, and there + -- are no unifications, so we must have emitted one or more constraints do { let lhs_redn = mkReflRedn role ps_xi1 rhs_redn = mkGReflRightRedn role xi2 mb_sym_kind_co mb_sym_kind_co = case swapped of @@ -1636,8 +1639,11 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ]) ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn - ; let new_xi2 = mkCastTy ps_xi2 mb_sym_kind_co - ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 }} + -- The rewritten equality is non-canonical, so put it straight in the Irreds + ; finishCanWithIrred (NonCanonicalReason (cteProblem cteCoercionHole)) type_ev } } + +-- ; let new_xi2 = mkCastTy ps_xi2 mb_sym_kind_co +-- ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 }} where mk_kind_eq :: TcS (CoercionN, RewriterSet, Bool) @@ -2044,19 +2050,20 @@ What do we do when we have an equality where k1 and k2 differ? Easy: we create a coercion that relates k1 and k2 and use this to cast. To wit, from - [X] (tv :: k1) ~ (rhs :: k2) + [X] co1 :: (tv :: k1) ~ (rhs :: k2) (where [X] is [G] or [W]), we go to - [X] co :: k1 ~ k2 - [X] (tv :: k1) ~ ((rhs |> sym co) :: k1) + co1 = co2 ; sym (GRefl kco) + [X] co2 :: (tv :: k1) ~ ((rhs |> sym kco) :: k1) + [X] kco :: k1 ~ k2 Wrinkles: -(EIK1) When X is W, the new type-level wanted is effectively rewritten by the - kind-level one. We thus include the kind-level wanted in the RewriterSet - for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. - This is done in canEqCanLHSHetero. +(EIK1) When X=Wanted, the new type-level wanted for `co` is effectively rewritten by + the kind-level one. We thus include the kind-level wanted in the RewriterSet + for the type-level one. See Note [Wanteds rewrite Wanteds] in + GHC.Tc.Types.Constraint. This is done in canEqCanLHSHetero. (EIK2) Suppose we have [W] (a::Type) ~ (b::Type->Type). The above rewrite will produce [W] w : a ~ (b |> kw) @@ -2076,7 +2083,7 @@ Wrinkles: Instead, it lands in the inert_irreds in the inert set, awaiting solution of that `kw`. - (EIK2a) We must later indeed unify if/when the kind-level wanted, `kw` gets + (EIK2a) We must later indeed unify if/when the kind-level wanted, `kw` gets solved. This is done in `kickOutAfterFillingCoercionHole`, which kicks out all equalities whose RHS mentions the filled-in coercion hole. Note that it looks for type family equalities, too, because of the use of unifyTest @@ -2086,7 +2093,7 @@ Wrinkles: which records that `w` has been rewritten by `kw`. See (WRW3) in Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. - (EIK2b) What if the RHS mentions /other/ coercion holes? How can that happen? The + (EIK2b) What if the RHS mentions /other/ coercion holes? How can that happen? The main way is like this. Assume F :: forall k. k -> Type [W] kw : k ~ Type [W] w : a ~ F k t @@ -2097,15 +2104,32 @@ Wrinkles: rewriting. Indeed tests JuanLopez only typechecks if we do. So we'd like to treat this kind of equality as canonical. - Hence the ch_hetero_kind field in CoercionHole: it is True of constraints - created by `canEqCanLHSHetero` to fix up hetero-kinded equalities; and False otherwise: + So here is our implementation: + * The `ch_hetero_kind` field in CoercionHole identifies a coercion hole created + by `canEqCanLHSHetero` to fix up hetero-kinded equalities. * An equality constraint is non-canonical if it mentions a hetero-kind - CoercionHole on the RHS. See the `hasCoercionHoleCo` test in GHC.Tc.Utils.checkCo. + CoercionHole on the RHS. This (and only this) is the (TyEq:CH) invariant + for canonical equalities (see Note [Canonical equalities]) + + * The invariant is checked by See the `hasCoercionHoleCo` test in + GHC.Tc.Utils.Unify.checkCo. , and is what `cteCoercionHole` reason in + `CheckTyEqResult` means. + + * These special hetero-kind CoercionHoles are created by the `uType` unifier when + the parent's CtOrigin is KindEqOrigin: see GHC.Tc.Utils.TcMType.newCoercionHole + and friends. + + We set this origin, via `updUEnvLoc`, in `mk_kind_eq` in `canEqCanLHSHetero`. + + * We /also/ add the coercion hole to the `RewriterSet` of the constraint, + in `canEqCanLHSHetero` + + * When filling one of these special hetero-kind coercion holes, we kick out + any IrredCt's that mention this hole; maybe it is now canonical. + See `kickOutAfterFillingCoercionHole`. - * Hetero-kind CoercionHoles are created when the parent's CtOrigin is - KindEqOrigin: see GHC.Tc.Utils.TcMType.newCoercionHole and friends. We - set this origin, via `mkKindLoc`, in `mk_kind_eq` in `canEqCanLHSHetero`. + Gah! This is bizarrely complicated. (EIK3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the algorithm detailed here, producing [W] co :: k1 ~ k2, and adding ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -466,10 +466,13 @@ kickOutAfterUnification tv_list = case nonEmpty tv_list of ; return n_kicked } kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () --- See Wrinkle (EIK2a) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality +-- See Wrinkle (EIK2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality -- It's possible that this could just go ahead and unify, but could there be occurs-check -- problems? Seems simpler just to kick out. kickOutAfterFillingCoercionHole hole + | not (isHeteroKindCoHole hole) + = return () -- Only hetero-kind coeercion holes provoke kick-out + | otherwise = do { ics <- getInertCans ; let (kicked_out, ics') = kick_out ics n_kicked = lengthBag kicked_out @@ -493,9 +496,9 @@ kickOutAfterFillingCoercionHole hole where (irreds_to_kick, irreds_to_keep) = partitionBag kick_ct irreds - kick_ct :: IrredCt -> Bool - -- True: kick out; False: keep. - kick_ct ct + kick_ct :: IrredCt -> Bool -- True: kick out; False: keep. + kick_ct ct -- See (EIK2) in Note [Equalities with incompatible kinds] + -- for this very specific kick-ot stuff | IrredCt { ir_ev = ev, ir_reason = reason } <- ct , CtWanted (WantedCt { ctev_rewriters = RewriterSet rewriters }) <- ev , NonCanonicalReason ctyeq <- reason ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -241,17 +241,23 @@ instance Outputable DictCt where ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An EqCt is a canonical equality constraint, one that can live in the inert set, and that can be used to rewrite other constraints. It satisfies these invariants: + * (TyEq:OC) lhs does not occur in rhs (occurs check) Note [EqCt occurs check] + * (TyEq:F) rhs has no foralls (this avoids substituting a forall for the tyvar in other types) + * (TyEq:K) typeKind lhs `tcEqKind` typeKind rhs; Note [Ct kind invariant] + * (TyEq:N) If the equality is representational, rhs is not headed by a saturated application of a newtype TyCon. See GHC.Tc.Solver.Equality Note [No top-level newtypes on RHS of representational equalities]. (Applies only when constructor of newtype is in scope.) + * (TyEq:U) An EqCt is not immediately unifiable. If we can unify a:=ty, we will not form an EqCt (a ~ ty). + * (TyEq:CH) rhs does not mention any coercion holes that resulted from fixing up a hetero-kinded equality. See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality, wrinkle (EIK2) @@ -534,9 +540,12 @@ cteSolubleOccurs = CTEP (bit 3) -- Occurs-check under a type function, or in -- cteSolubleOccurs must be one bit to the left of cteInsolubleOccurs -- See also Note [Insoluble mis-match] in GHC.Tc.Errors -cteCoercionHole = CTEP (bit 4) -- Coercion hole encountered +cteCoercionHole = CTEP (bit 4) -- Kind-equality coercion hole encountered + -- See (EIK2) in Note [Equalities with incompatible kinds] + cteConcrete = CTEP (bit 5) -- Type variable that can't be made concrete -- e.g. alpha[conc] ~ Maybe beta[tv] + cteSkolemEscape = CTEP (bit 6) -- Skolem escape e.g. alpha[2] ~ b[sk,4] cteProblem :: CheckTyEqProblem -> CheckTyEqResult ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -369,6 +369,7 @@ newCoercionHoleO (KindEqOrigin {}) pty = new_coercion_hole True pty newCoercionHoleO _ pty = new_coercion_hole False pty new_coercion_hole :: Bool -> TcPredType -> TcM CoercionHole +-- For the Bool, see (EIK2) in Note [Equalities with incompatible kinds] new_coercion_hole hetero_kind pred_ty = do { co_var <- newEvVar pred_ty ; traceTc "New coercion hole:" (ppr co_var <+> dcolon <+> ppr pred_ty) ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -578,13 +578,12 @@ zonkCtEvRewriterSet ev@(CtWanted wtd) = do { rewriters' <- zonkRewriterSet (ctEvRewriters ev) ; return (CtWanted $ setWantedCtEvRewriters wtd rewriters') } --- | Check whether any coercion hole in a RewriterSet is still unsolved. --- Does this by recursively looking through filled coercion holes until --- one is found that is not yet filled in, at which point this aborts. +-- | Zonk a rewriter set; if a coercion hole in the set has been filled, +-- find all the free un-filled coercion holes in the coercion that fills it zonkRewriterSet :: RewriterSet -> ZonkM RewriterSet zonkRewriterSet (RewriterSet set) = nonDetStrictFoldUniqSet go (return emptyRewriterSet) set - -- this does not introduce non-determinism, because the only + -- This does not introduce non-determinism, because the only -- monadic action is to read, and the combining function is -- commutative where @@ -592,10 +591,11 @@ zonkRewriterSet (RewriterSet set) go hole m_acc = unionRewriterSet <$> check_hole hole <*> m_acc check_hole :: CoercionHole -> ZonkM RewriterSet - check_hole hole = do { m_co <- unpackCoercionHole_maybe hole - ; case m_co of - Nothing -> return (unitRewriterSet hole) - Just co -> unUCHM (check_co co) } + check_hole hole + = do { m_co <- unpackCoercionHole_maybe hole + ; case m_co of + Nothing -> return (unitRewriterSet hole) -- Not filled + Just co -> unUCHM (check_co co) } -- Filled: look inside check_ty :: Type -> UnfilledCoercionHoleMonoid check_co :: Coercion -> UnfilledCoercionHoleMonoid View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d2a3dbc6d00dae8f79676846b2a51f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d2a3dbc6d00dae8f79676846b2a51f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] Wibble to postInlineUnconditionally
by Simon Peyton Jones (＠simonpj) 21 Apr '25

21 Apr '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: ef3ab33f by Simon Peyton Jones at 2025-04-21T22:38:03+01:00 Wibble to postInlineUnconditionally - - - - - 1 changed file: - compiler/GHC/Core/Opt/Simplify/Utils.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1632,7 +1632,8 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs is_demanded = isStrUsedDmd (idDemandInfo bndr) occ_info = idOccInfo old_bndr unfolding = idUnfolding bndr - is_cheap = isCheapUnfolding unfolding + arity = idArity bndr +-- is_cheap = isCheapUnfolding unfolding uf_opts = seUnfoldingOpts env phase = sePhase env active = isActive phase (idInlineActivation bndr) @@ -1650,10 +1651,10 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs check_one_occ NotInsideLam NotInteresting n_br = not is_top_lvl && code_dup_ok n_br check_one_occ NotInsideLam IsInteresting n_br = code_dup_ok n_br check_one_occ IsInsideLam NotInteresting _ = False - check_one_occ IsInsideLam IsInteresting n_br = is_cheap && code_dup_ok n_br + check_one_occ IsInsideLam IsInteresting n_br = arity > 0 && code_dup_ok n_br -- IsInteresting: inlining inside a lambda only with good reason -- See the notes on int_cxt in preInlineUnconditionally - -- is_cheap: check for acceptable work duplication, using isCheapUnfolding + -- arity>0: do not inline data strutures under lambdas, only functions --------------- -- A wrong bit of code, left here in case you are tempted to do this View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef3ab33f9059ffd999e8adea458586a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef3ab33f9059ffd999e8adea458586a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

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

21 Apr '25

Serge S. Gulin pushed to branch wip/T24603 at Glasgow Haskell Compiler / GHC Commits: 14effa72 by Serge S. Gulin at 2025-04-21T22:15:21+03:00 Bisect attempt for ghc js backend submodule - - - - - 1 changed file: - libraries/Cabal Changes: ===================================== libraries/Cabal ===================================== @@ -1 +1 @@ -Subproject commit 703582f80f6d7f0c914ef4b885affcfc7b7b6ec8 +Subproject commit 1103d01101a1e23c306ab788f46f377e96b2bb94 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14effa7276a1820fc4292f9df071c4a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14effa7276a1820fc4292f9df071c4a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] 117 commits: Refactor Handling of Multiple Default Declarations
by Alan Zimmerman (＠alanz) 21 Apr '25

21 Apr '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: e0f3ff11 by Patrick at 2025-04-17T04:31:12-04:00 Refactor Handling of Multiple Default Declarations Fixes: #25912, #25914, #25934 Previously, GHC discarded all loaded defaults (tcg_default) when local defaults were encountered during typechecking. According to the exportable-named-default proposal (sections 2.4.2 and 2.4.3), local defaults should be merged into tcg_default, retaining any defaults already present while overriding where necessary. Key Changes: * Introduce DefaultProvenance to track the origin of default declarations (local, imported, or built-in), replacing the original cd_module in ClassDefaults with cd_provenance :: DefaultProvenance. * Rename tcDefaults to tcDefaultDecls, limiting its responsibility to only converting renamed class defaults into ClassDefaults. * Add extendDefaultEnvWithLocalDefaults to merge local defaults into the environment, with proper duplication checks: - Duplicate local defaults for a class trigger an error. - Local defaults override imported or built-in defaults. * Update and add related notes: Note [Builtin class defaults], Note [DefaultProvenance]. * Add regression tests: T25912, T25914, T25934. Thanks sam and simon for the help on this patch. Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - 386f1854 by Teo Camarasu at 2025-04-17T04:31:55-04:00 template-haskell: Remove `addrToByteArrayName` and `addrToByteArray` These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage. Resolves #24782 - - - - - b96e2f77 by Sylvain Henry at 2025-04-18T20:46:33-04:00 RTS: remove target info and fix host info (#24058) The RTS isn't a compiler, hence it doesn't have a target and we remove the reported target info displayed by "+RTS --info". We also fix the host info displayed by "+RTS --info": the host of the RTS is the RTS-building compiler's target, not the compiler's host (wrong when doing cross-compilation). - - - - - 6d9965f4 by Sylvain Henry at 2025-04-18T20:46:33-04:00 RTS: remove build info As per the discussion in !13967, there is no reason to tag the RTS with information about the build platform. - - - - - d52e9b3f by Vladislav Zavialov at 2025-04-18T20:47:15-04:00 Diagnostics: remove the KindMismatch constructor (#25957) The KindMismatch constructor was only used as an intermediate representation in pretty-printing. Its removal addresses a problem detected by the "codes" test case: [GHC-89223] is untested (constructor = KindMismatch) In a concious deviation from the usual procedure, the error code GHC-89223 is removed entirely rather than marked as Outdated. The reason is that it never was user-facing in the first place. - - - - - e2f2f9d0 by Vladislav Zavialov at 2025-04-20T10:53:39-04:00 Add name for -Wunusable-unpack-pragmas This warning had no name or flag and was triggered unconditionally. Now it is part of -Wdefault. In GHC.Tc.TyCl.tcTyClGroupsPass's strict mode, we now have to force-enable this warning to ensure that detection of flawed groups continues to work even if the user disables the warning with the -Wno-unusable-unpack-pragmas option. Test case: T3990c Also, the misnamed BackpackUnpackAbstractType is now called UnusableUnpackPragma. - - - - - 6caa6508 by Adam Gundry at 2025-04-20T10:54:22-04:00 Fix specialisation of incoherent instances (fixes #25883) GHC normally assumes that class constraints are canonical, meaning that the specialiser is allowed to replace one dictionary argument with another provided that they have the same type. The `-fno-specialise-incoherents` flag alters INCOHERENT instance definitions so that they will prevent specialisation in some cases, by inserting `nospec`. This commit fixes a bug in 7124e4ad76d98f1fc246ada4fd7bf64413ff2f2e, which treated some INCOHERENT instance matches as if `-fno-specialise-incoherents` was in effect, thereby unnecessarily preventing specialisation. In addition it updates the relevant `Note [Rules for instance lookup]` and adds a new `Note [Canonicity for incoherent matches]`. - - - - - 0426fd6c by Adam Gundry at 2025-04-20T10:54:23-04:00 Add regression test for #23429 - - - - - eec96527 by Adam Gundry at 2025-04-20T10:54:23-04:00 user's guide: update specification of overlapping/incoherent instances The description of the instance resolution algorithm in the user's guide was slightly out of date, because it mentioned in-scope given constraints only at the end, whereas the implementation checks for their presence before any of the other steps. This also adds a warning to the user's guide about the impact of incoherent instances on specialisation, and more clearly documents some of the other effects of `-XIncoherentInstances`. - - - - - a00eeaec by Matthew Craven at 2025-04-20T10:55:03-04:00 Fix bytecode generation for `tagToEnum# <LITERAL>` Fixes #25975. - - - - - ea5fab39 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 GHC-CPP: first rough proof of concept 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 - - - - - e73abe65 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Tidy up before re-visiting the continuation mechanic - - - - - 496b05a4 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Switch preprocessor to continuation passing style Proof of concept, needs tidying up - - - - - 7d770792 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Small cleanup - - - - - 4436589a by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Get rid of some cruft - - - - - 703f0997 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Starting to integrate. Need to get the pragma recognised and set - - - - - d41cf158 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Make cppTokens extend to end of line, and process CPP comments - - - - - 5473a8f8 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Remove unused ITcppDefined - - - - - 6e761c77 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Allow spaces between # and keyword for preprocessor directive - - - - - a963ddf1 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 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. - - - - - a27ddbe1 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Accumulate CPP continuations, process when ready Can be simplified further, we only need one CPP token - - - - - aecedf1a by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Simplify Lexer interface. Only ITcpp We transfer directive lines through it, then parse them from scratch in the preprocessor. - - - - - a8124788 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Deal with directive on last line, with no trailing \n - - - - - 07258013 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Start parsing and processing the directives - - - - - da41c32b by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Prepare for processing include files - - - - - 74fc7700 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Move PpState into PreProcess And initParserState, initPragState too - - - - - 3629caba by Alan Zimmerman at 2025-04-21T18:44:33+01:00 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 - - - - - 30f795fb by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Split into separate files - - - - - fce63df8 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Starting on expression parser. But it hangs. Time for Text.Parsec.Expr - - - - - a777ca97 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Start integrating the ghc-cpp work From https://github.com/alanz/ghc-cpp - - - - - 053eb592 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 WIP - - - - - b71ec92e by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Fixup after rebase - - - - - e439eaa3 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 WIP - - - - - c01bf5b6 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Fixup after rebase, including all tests pass - - - - - e0ba1ec8 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Change pragma usage to GHC_CPP from GhcCPP - - - - - c1b68436 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Some comments - - - - - dede9429 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Reformat - - - - - 4eed4283 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Delete unused file - - - - - f2e37212 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Rename module Parse to ParsePP - - - - - 45457d52 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Clarify naming in the parser - - - - - 87c77e37 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 WIP. Switching to alex/happy to be able to work in-tree Since Parsec is not available - - - - - c529a377 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 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 - - - - - ebd2fd33 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 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 ``` - - - - - 8537a9c0 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 Rebase, and all tests pass except whitespace for generated parser - - - - - 1807c3e1 by Alan Zimmerman at 2025-04-21T18:44:33+01:00 More plumbing. Ready for testing tomorrow. - - - - - d62a7992 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Proress. Renamed module State from Types And at first blush it seems to handle preprocessor scopes properly. - - - - - 21d99768 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Insert basic GHC version macros into parser __GLASGOW_HASKELL__ __GLASGOW_HASKELL_FULL_VERSION__ __GLASGOW_HASKELL_PATCHLEVEL1__ __GLASGOW_HASKELL_PATCHLEVEL2__ - - - - - a5c97101 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Re-sync check-cpp for easy ghci work - - - - - 88fbbb68 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Get rid of warnings - - - - - 159e3f5c by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Rework macro processing, in check-cpp Macros kept at the top level, looked up via name, multiple arity versions per name can be stored - - - - - 26de6c7a by Alan Zimmerman at 2025-04-21T18:44:34+01:00 WIP. Can crack arguments for #define Next step it to crack out args in an expansion - - - - - 08a4bc32 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 WIP on arg parsing. - - - - - e9f20c47 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Progress. Still screwing up nested parens. - - - - - 2ddc204e by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Seems to work, but has redundant code - - - - - 39c9fff2 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Remove redundant code - - - - - 9738906c by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Reformat - - - - - 8b7bc8fc by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Expand args, single pass Still need to repeat until fixpoint - - - - - faf74e30 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Fixed point expansion - - - - - a72b05b6 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Sync the playground to compiler - - - - - ed57b7a2 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Working on dumping the GHC_CPP result But We need to keep the BufSpan in a comment - - - - - 19fe2968 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Keep BufSpan in queued comments in GHC.Parser.Lexer - - - - - f468e163 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Getting close to being able to print the combined tokens showing what is in and what is out - - - - - 6fbb06cf by Alan Zimmerman at 2025-04-21T18:44:34+01:00 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 - - - - - 6c4ee20f by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Clean up a bit - - - - - 85d45f08 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Add -ddump-ghc-cpp option and a test based on it - - - - - 2df9e747 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Restore Lexer.x rules, we need them for continuation lines - - - - - 06069b87 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 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 - - - - - a6f7ba7e by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Inserts predefined macros. But does not dump properly Because the cpp tokens have a trailing newline - - - - - 19c9b350 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Remove unnecessary LExer rules We *need* the ones that explicitly match to the end of the line. - - - - - d94b37b7 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 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. - - - - - 4a6b9234 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Reduce duplication in lexer - - - - - 4ee7b8cb by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Tweaks - - - - - 04d0978c by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Insert min_version predefined macros into state The mechanism now works. Still need to flesh out the full set. - - - - - 31c434f2 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Trying my alternative pragma syntax. It works, but dumpGhcCpp is broken, I suspect from the ITcpp token span update. - - - - - 58842a2c by Alan Zimmerman at 2025-04-21T18:44:34+01:00 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 - - - - - d58d5a85 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Remove some tracing - - - - - db54555f by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Fix test exes for changes - - - - - 78aea61f by Alan Zimmerman at 2025-04-21T18:44:34+01:00 For GHC_CPP tests, normalise config-time-based macros - - - - - c843e1f6 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 WIP - - - - - f91a3167 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 WIP again. What is wrong? - - - - - d9bd7e2d by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Revert to dynflags for normal not pragma lexing - - - - - aff258ca by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Working on getting check-exact to work properly - - - - - 057b2d78 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Passes CppCommentPlacement test - - - - - d5f7efa3 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Starting on exact printing with GHC_CPP While overriding normal CPP - - - - - 69c1dbeb by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Correctly store CPP ignored tokens as comments By populating the lexeme string in it, based on the bufpos - - - - - 2f9ae126 by Alan Zimmerman at 2025-04-21T18:44:34+01:00 WIP - - - - - 6d55843e by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Simplifying - - - - - 865f357f by Alan Zimmerman at 2025-04-21T18:44:34+01:00 Update the active state logic - - - - - 95f7764c by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Work the new logic into the mainline code - - - - - c4eddc92 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Process `defined` operator - - - - - 2df85e87 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 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. - - - - - 0100b713 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 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. - - - - - 073704da by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Process the ! operator in GHC_CPP expressions - - - - - 0cc4f052 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Predefine a constant when GHC_CPP is being used. - - - - - a3a17006 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 WIP - - - - - 384034da by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Skip lines directly in the lexer when required - - - - - 58f8e94f by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Properly manage location when accepting tokens again - - - - - 0975166e by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Seems to be working now, for Example9 - - - - - 3a8b34f1 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Remove tracing - - - - - f35bf0c3 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Fix parsing '*' in block comments Instead of replacing them with '-' - - - - - 430e0c92 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Keep the trailing backslash in a ITcpp token - - - - - a15bb515 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 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 - - - - - cb88f9a5 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Replace remaining identifiers with 0 when evaluating As per the spec - - - - - 1c0d10fc by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Snapshot before rebase - - - - - beb2cf2e by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Skip non-processed lines starting with # - - - - - 4e7fbb22 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Export generateMacros so we can use it in ghc-exactprint - - - - - 50cdeda7 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Fix rebase - - - - - de4a5656 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Expose initParserStateWithMacrosString - - - - - faafb98f by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Fix buggy lexer cppSkip It was skipping all lines, not just ones prefixed by # - - - - - abc6dd80 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Fix evaluation of && to use the correct operator - - - - - 6759b157 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Deal with closing #-} at the start of a line - - - - - aaea5fe1 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Add the MIN_VERSION_GLASGOW_HASKELL predefined macro - - - - - 4725ad9f by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Include MIN_VERSION_GLASGOW_HASKELL in GhcCpp01.stderr - - - - - 8144afb6 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Use a strict map for macro defines - - - - - 937902ae by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Process TIdentifierLParen Which only matters at the start of #define - - - - - 0b4c36a4 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Do not provide TIdentifierLParen paren twice - - - - - e2eef871 by Alan Zimmerman at 2025-04-21T18:44:35+01:00 Handle whitespace between identifier and '(' for directive only - - - - - 138 changed files: - compiler/GHC.hs - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/Parser/Monad.hs - compiler/GHC/Core/InstEnv.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Config/Parser.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.hs-boot - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.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/Eval.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/StgToByteCode.hs - compiler/GHC/SysTools/Cpp.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/DefaultEnv.hs - compiler/GHC/Types/Error/Codes.hs - compiler/ghc.cabal.in - configure.ac - docs/users_guide/9.14.1-notes.rst - docs/users_guide/debugging.rst - docs/users_guide/exts/instances.rst - docs/users_guide/using-warnings.rst - ghc/GHCi/UI.hs - hadrian/src/Rules/SourceDist.hs - hadrian/src/Settings/Packages.hs - hadrian/stack.yaml.lock - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - libraries/template-haskell/changelog.md - rts/RtsUtils.c - testsuite/ghc-config/ghc-config.hs - + testsuite/tests/bytecode/T25975.hs - + testsuite/tests/bytecode/T25975.stdout - testsuite/tests/bytecode/all.T - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/default/T25912.hs - + testsuite/tests/default/T25912.stdout - + testsuite/tests/default/T25912_helper.hs - + testsuite/tests/default/T25914.hs - + testsuite/tests/default/T25934.hs - testsuite/tests/default/all.T - testsuite/tests/default/default-fail03.stderr - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/driver/T4437.hs - testsuite/tests/ghc-api/T11579.hs - + testsuite/tests/ghc-cpp/GhcCpp01.hs - + testsuite/tests/ghc-cpp/GhcCpp01.stderr - + testsuite/tests/ghc-cpp/all.T - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/linters/notes.stdout - testsuite/tests/module/mod58.stderr - + testsuite/tests/printer/CppCommentPlacement.hs - testsuite/tests/simplCore/should_compile/Makefile - testsuite/tests/simplCore/should_compile/T23307c.stderr - + testsuite/tests/simplCore/should_compile/T25883.hs - + testsuite/tests/simplCore/should_compile/T25883.substr-simpl - + testsuite/tests/simplCore/should_compile/T25883b.hs - + testsuite/tests/simplCore/should_compile/T25883b.substr-simpl - + testsuite/tests/simplCore/should_compile/T25883c.hs - + testsuite/tests/simplCore/should_compile/T25883c.substr-simpl - + testsuite/tests/simplCore/should_compile/T25883d.hs - + testsuite/tests/simplCore/should_compile/T25883d.stderr - + testsuite/tests/simplCore/should_compile/T25883d_import.hs - + testsuite/tests/simplCore/should_compile/T3990c.hs - + testsuite/tests/simplCore/should_compile/T3990c.stdout - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/simplCore/should_fail/T25672.stderr - + testsuite/tests/simplCore/should_run/T23429.hs - + testsuite/tests/simplCore/should_run/T23429.stdout - testsuite/tests/simplCore/should_run/all.T - testsuite/tests/typecheck/should_compile/T7050.stderr - testsuite/tests/typecheck/should_fail/T3966.stderr - + testsuite/tests/typecheck/should_fail/T3966b.hs - + testsuite/tests/typecheck/should_fail/T3966b.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/unboxedsums/unpack_sums_5.stderr - + utils/check-cpp/.ghci - + utils/check-cpp/.gitignore - + utils/check-cpp/Eval.hs - + utils/check-cpp/Example1.hs - + utils/check-cpp/Example10.hs - + utils/check-cpp/Example11.hs - + utils/check-cpp/Example12.hs - + utils/check-cpp/Example13.hs - + utils/check-cpp/Example2.hs - + utils/check-cpp/Example3.hs - + utils/check-cpp/Example4.hs - + utils/check-cpp/Example5.hs - + utils/check-cpp/Example6.hs - + utils/check-cpp/Example7.hs - + utils/check-cpp/Example8.hs - + utils/check-cpp/Example9.hs - + utils/check-cpp/Lexer.x - + utils/check-cpp/Macro.hs - + utils/check-cpp/Main.hs - + utils/check-cpp/ParsePP.hs - + utils/check-cpp/ParseSimulate.hs - + utils/check-cpp/Parser.y - + utils/check-cpp/ParserM.hs - + utils/check-cpp/PreProcess.hs - + utils/check-cpp/README.md - + utils/check-cpp/State.hs - + utils/check-cpp/run.sh - 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/b5ae074ed7855ebd5b0c61e67cf4de… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b5ae074ed7855ebd5b0c61e67cf4de… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/riscv-vectors] 3 commits: Implement MO_VS_Quot and MO_VU_Quot
by Sven Tennie (＠supersven) 21 Apr '25

21 Apr '25

Sven Tennie pushed to branch wip/supersven/riscv-vectors at Glasgow Haskell Compiler / GHC Commits: b22c53e1 by Sven Tennie at 2025-04-20T12:08:16+02:00 Implement MO_VS_Quot and MO_VU_Quot - - - - - d8441ea3 by Sven Tennie at 2025-04-20T13:12:41+02:00 Implement MO_X64 and MO_W64 CallishOps - - - - - 4b485b8c by Sven Tennie at 2025-04-21T19:27:09+02:00 WIP: Vector shuffle - - - - - 3 changed files: - compiler/GHC/CmmToAsm/RV64/CodeGen.hs - compiler/GHC/CmmToAsm/RV64/Instr.hs - compiler/GHC/CmmToAsm/RV64/Ppr.hs Changes: ===================================== compiler/GHC/CmmToAsm/RV64/CodeGen.hs ===================================== @@ -1294,7 +1294,7 @@ getRegister' config plat expr = MO_V_Sub length w -> vecOp (intVecFormat length w) VSUB MO_VF_Mul length w -> vecOp (floatVecFormat length w) VMUL MO_V_Mul length w -> vecOp (intVecFormat length w) VMUL - MO_VF_Quot length w -> vecOp (floatVecFormat length w) VQUOT + MO_VF_Quot length w -> vecOp (floatVecFormat length w) (VQUOT Nothing) -- See https://godbolt.org/z/PvcWKMKoW MO_VS_Min length w -> vecOp (intVecFormat length w) VSMIN MO_VS_Max length w -> vecOp (intVecFormat length w) VSMAX @@ -1302,6 +1302,66 @@ getRegister' config plat expr = MO_VU_Max length w -> vecOp (intVecFormat length w) VUMAX MO_VF_Min length w -> vecOp (floatVecFormat length w) VFMIN MO_VF_Max length w -> vecOp (floatVecFormat length w) VFMAX + MO_V_Shuffle length w idxs -> do + -- Our strategy: + -- - Gather elemens of v1 on the right positions + -- - Gather elemenrs of v2 of the right positions + -- - Merge v1 and v2 with an adequate bitmask (v0) + lbl_selVec_v1 <- getNewLabelNat + lbl_selVec_v2 <- getNewLabelNat + + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + + let (idxs_v1, idxs_v2) = + mapTuple reverse + $ foldl' + ( \(acc1, acc2) i -> + if i < length then (Just i : acc1, Nothing : acc2) else (Nothing : acc1, Just (i - length) : acc2) + ) + ([], []) + idxs + selVecData_v1 = selVecData idxs_v1 + selVecData_v2 = selVecData idxs_v2 + selVecFormat = intVecFormat length W16 + dstFormat = intVecFormat length w + addrFormat = intFormat W64 + sel_v1 <- getNewRegNat selVecFormat + sel_v2 <- getNewRegNat selVecFormat + sel_v1_addr <- getNewRegNat addrFormat + sel_v2_addr <- getNewRegNat addrFormat + gathered_x <- getNewRegNat format_x + gathered_y <- getNewRegNat format_y + pure $ Any dstFormat $ \dst -> + toOL + [ LDATA (Section ReadOnlyData lbl_selVec_v1) (CmmStaticsRaw lbl_selVec_v1 selVecData_v1), + LDATA (Section ReadOnlyData lbl_selVec_v2) (CmmStaticsRaw lbl_selVec_v2 selVecData_v2) + ] + `appOL` code_x + `appOL` code_y + `appOL` toOL + [ LDR addrFormat (OpReg addrFormat sel_v1_addr) (OpImm (ImmCLbl lbl_selVec_v1)), + LDR addrFormat (OpReg addrFormat sel_v2_addr) (OpImm (ImmCLbl lbl_selVec_v2)), + LDRU selVecFormat (OpReg selVecFormat sel_v1) (OpAddr (AddrReg sel_v1_addr)), + LDRU selVecFormat (OpReg selVecFormat sel_v2) (OpAddr (AddrReg sel_v2_addr)), + VRGATHER (OpReg format_x gathered_x) (OpReg format_x reg_x) (OpReg selVecFormat sel_v1), + VRGATHER (OpReg format_y gathered_y) (OpReg format_y reg_y) (OpReg selVecFormat sel_v2), + VMV (OpReg selVecFormat v0Reg) (OpReg selVecFormat sel_v1), + VMERGE (OpReg dstFormat dst)(OpReg format_x gathered_x)(OpReg format_y gathered_y) (OpReg selVecFormat v0Reg) + ] + where + mapTuple :: (a -> b) -> (a, a) -> (b, b) + mapTuple f (x, y) = (f x, f y) + selVecData :: [Maybe Int] -> [CmmStatic] + selVecData idxs = + (CmmStaticLit . (flip CmmInt) W16 . fromIntegral) + `map` ( map + ( \i -> case i of + Just i' -> i' + Nothing -> 0 + ) + idxs + ) _e -> panic $ "Missing operation " ++ show expr -- Generic ternary case. @@ -1331,7 +1391,6 @@ getRegister' config plat expr = expr (VMV (OpReg targetFormat dst) (OpReg format_x reg_x)) `snocOL` VFMA var (OpReg targetFormat dst) (OpReg format_y reg_y) (OpReg format_z reg_z) - MO_VF_Insert length width -> vecInsert floatVecFormat length width MO_V_Insert length width -> vecInsert intVecFormat length width _ -> @@ -1348,7 +1407,7 @@ getRegister' config plat expr = (reg_idx, format_idx, code_idx) <- getSomeReg z let format = toFormat length width format_mask = intVecFormat length W8 -- Actually, W1 (one bit) would be correct, but that does not exist. - format_vid = intVecFormat length vidWidth + format_vid = intVecFormat length (vidWidth length) vidReg <- getNewRegNat format_vid tmp <- getNewRegNat format pure $ Any format $ \dst -> @@ -1373,18 +1432,20 @@ getRegister' config plat expr = `snocOL` -- 4. Merge with mask -> set element at index VMERGE (OpReg format dst) (OpReg format_v reg_v) (OpReg format tmp) (OpReg format_mask v0Reg) + + -- Which element width do I need in my vector to store indexes in it? + vidWidth :: Int -> Width + vidWidth length = case bitWidthFixed (fromIntegral length :: Word) of + x + | x <= widthInBits W8 -> W8 + | x <= widthInBits W16 -> W16 + | x <= widthInBits W32 -> W32 + | x <= widthInBits W64 -> W64 + | x <= widthInBits W128 -> W128 + | x <= widthInBits W256 -> W256 + | x <= widthInBits W512 -> W512 + e -> panic $ "length " ++ show length ++ "not representable in a single element's Width (" ++ show e ++ ")" where - -- Which element width do I need in my vector to store indexes in it? - vidWidth = case bitWidthFixed (fromIntegral length :: Word) of - x - | x <= widthInBits W8 -> W8 - | x <= widthInBits W16 -> W16 - | x <= widthInBits W32 -> W32 - | x <= widthInBits W64 -> W64 - | x <= widthInBits W128 -> W128 - | x <= widthInBits W256 -> W256 - | x <= widthInBits W512 -> W512 - e -> panic $ "length " ++ show length ++ "not representable in a single element's Width (" ++ show e ++ ")" bitWidthFixed :: Word -> Int bitWidthFixed 0 = 1 bitWidthFixed n = finiteBitSize n - countLeadingZeros n @@ -1489,14 +1550,6 @@ getRegister' config plat expr = ) -- TODO: Missing MachOps: --- - MO_V_Add --- - MO_V_Sub --- - MO_V_Mul --- - MO_VS_Quot --- - MO_VS_Rem --- - MO_VS_Neg --- - MO_VU_Quot --- - MO_VU_Rem -- - MO_V_Shuffle -- - MO_VF_Shuffle @@ -2142,19 +2195,45 @@ genCCall (PrimTarget mop) dest_regs arg_regs = do MO_AddIntC _w -> unsupported mop MO_SubIntC _w -> unsupported mop MO_U_Mul2 _w -> unsupported mop + MO_VS_Quot length w + | [x, y] <- arg_regs, + [dst_reg] <- dest_regs -> + v3op mop (intVecFormat length w) dst_reg x y (VQUOT (Just Signed)) MO_VS_Quot {} -> unsupported mop + MO_VU_Quot length w + | [x, y] <- arg_regs, + [dst_reg] <- dest_regs -> + v3op mop (intVecFormat length w) dst_reg x y (VQUOT (Just Unsigned)) MO_VU_Quot {} -> unsupported mop MO_VS_Rem length w | [x, y] <- arg_regs, - [dst_reg] <- dest_regs -> vrem mop length w dst_reg x y Signed + [dst_reg] <- dest_regs -> + v3op mop (intVecFormat length w) dst_reg x y (VREM Signed) MO_VS_Rem {} -> unsupported mop MO_VU_Rem length w | [x, y] <- arg_regs, - [dst_reg] <- dest_regs -> vrem mop length w dst_reg x y Unsigned + [dst_reg] <- dest_regs -> + v3op mop (intVecFormat length w) dst_reg x y (VREM Unsigned) MO_VU_Rem {} -> unsupported mop + MO_I64X2_Min + | [x, y] <- arg_regs, + [dst_reg] <- dest_regs -> + v3op mop (intVecFormat 2 W64) dst_reg x y VSMIN MO_I64X2_Min -> unsupported mop + MO_I64X2_Max + | [x, y] <- arg_regs, + [dst_reg] <- dest_regs -> + v3op mop (intVecFormat 2 W64) dst_reg x y VSMAX MO_I64X2_Max -> unsupported mop + MO_W64X2_Min + | [x, y] <- arg_regs, + [dst_reg] <- dest_regs -> + v3op mop (intVecFormat 2 W64) dst_reg x y VUMIN MO_W64X2_Min -> unsupported mop + MO_W64X2_Max + | [x, y] <- arg_regs, + [dst_reg] <- dest_regs -> + v3op mop (intVecFormat 2 W64) dst_reg x y VUMAX MO_W64X2_Max -> unsupported mop -- Memory Ordering -- The related C functions are: @@ -2275,24 +2354,23 @@ genCCall (PrimTarget mop) dest_regs arg_regs = do let code = code_fx `appOL` op (OpReg fmt dst) (OpReg format_x reg_fx) pure code - vrem :: CallishMachOp -> Int -> Width -> LocalReg -> CmmExpr -> CmmExpr -> Signage -> NatM InstrBlock - vrem mop length w dst_reg x y s = do - platform <- getPlatform - let dst = getRegisterReg platform (CmmLocal dst_reg) - format = intVecFormat length w - moDescr = pprCallishMachOp mop - (reg_x, format_x, code_x) <- getSomeReg x - (reg_y, format_y, code_y) <- getSomeReg y - massertPpr (isVecFormat format_x && isVecFormat format_y) - $ text "vecOp: non-vector operand. operands: " - <+> ppr format_x - <+> ppr format_y - pure - $ code_x - `appOL` code_y - `snocOL` - ann moDescr - (VREM s (OpReg format dst) (OpReg format_x reg_x) (OpReg format_y reg_y)) + v3op :: CallishMachOp -> Format -> LocalReg -> CmmExpr -> CmmExpr -> (Operand -> Operand -> Operand -> Instr) -> NatM InstrBlock + v3op mop dst_format dst_reg x y op = do + platform <- getPlatform + let dst = getRegisterReg platform (CmmLocal dst_reg) + moDescr = pprCallishMachOp mop + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + massertPpr (isVecFormat format_x && isVecFormat format_y) + $ text "vecOp: non-vector operand. operands: " + <+> ppr format_x + <+> ppr format_y + pure + $ code_x + `appOL` code_y + `snocOL` ann + moDescr + (op (OpReg dst_format dst) (OpReg format_x reg_x) (OpReg format_y reg_y)) {- Note [RISCV64 far jumps] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2540,6 +2618,7 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks = VUMAX {} -> 2 VFMIN {} -> 2 VFMAX {} -> 2 + VRGATHER {} -> 2 VFMA {} -> 3 -- estimate the subsituted size for jumps to lables -- jumps to registers have size 1 ===================================== compiler/GHC/CmmToAsm/RV64/Instr.hs ===================================== @@ -119,14 +119,15 @@ regUsageOfInstr platform instr = case instr of VADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) VSUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) VMUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) - VQUOT dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) - VREM s dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + VQUOT _mbS dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + VREM _s dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) VSMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) VSMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) VUMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) VUMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) VFMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) VFMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + VRGATHER dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) FMA _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) VFMA _ op1 op2 op3 -> @@ -233,7 +234,7 @@ patchRegsOfInstr instr env = case instr of VADD o1 o2 o3 -> VADD (patchOp o1) (patchOp o2) (patchOp o3) VSUB o1 o2 o3 -> VSUB (patchOp o1) (patchOp o2) (patchOp o3) VMUL o1 o2 o3 -> VMUL (patchOp o1) (patchOp o2) (patchOp o3) - VQUOT o1 o2 o3 -> VQUOT (patchOp o1) (patchOp o2) (patchOp o3) + VQUOT mbS o1 o2 o3 -> VQUOT mbS (patchOp o1) (patchOp o2) (patchOp o3) VREM s o1 o2 o3 -> VREM s (patchOp o1) (patchOp o2) (patchOp o3) VSMIN o1 o2 o3 -> VSMIN (patchOp o1) (patchOp o2) (patchOp o3) VSMAX o1 o2 o3 -> VSMAX (patchOp o1) (patchOp o2) (patchOp o3) @@ -241,6 +242,7 @@ patchRegsOfInstr instr env = case instr of VUMAX o1 o2 o3 -> VUMAX (patchOp o1) (patchOp o2) (patchOp o3) VFMIN o1 o2 o3 -> VFMIN (patchOp o1) (patchOp o2) (patchOp o3) VFMAX o1 o2 o3 -> VFMAX (patchOp o1) (patchOp o2) (patchOp o3) + VRGATHER o1 o2 o3 -> VRGATHER (patchOp o1) (patchOp o2) (patchOp o3) FMA s o1 o2 o3 o4 -> FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) VFMA s o1 o2 o3 -> @@ -676,7 +678,7 @@ data Instr | VADD Operand Operand Operand | VSUB Operand Operand Operand | VMUL Operand Operand Operand - | VQUOT Operand Operand Operand + | VQUOT (Maybe Signage) Operand Operand Operand | VREM Signage Operand Operand Operand | VSMIN Operand Operand Operand | VSMAX Operand Operand Operand @@ -685,6 +687,7 @@ data Instr | VFMIN Operand Operand Operand | VFMAX Operand Operand Operand | VFMA FMASign Operand Operand Operand + | VRGATHER Operand Operand Operand data Signage = Signed | Unsigned deriving (Eq, Show) @@ -770,6 +773,7 @@ instrCon i = VUMAX {} -> "VUMAX" VFMIN {} -> "VFMIN" VFMAX {} -> "VFMAX" + VRGATHER {} -> "VRGATHER" FMA variant _ _ _ _ -> case variant of FMAdd -> "FMADD" ===================================== compiler/GHC/CmmToAsm/RV64/Ppr.hs ===================================== @@ -853,8 +853,10 @@ pprInstr platform instr = case instr of VMUL o1 o2 o3 | allIntVectorRegOps [o1, o2, o3] -> op3 (text "\tvmul.vv") o1 o2 o3 VMUL o1 o2 o3 | allFloatVectorRegOps [o1, o2, o3] -> op3 (text "\tvfmul.vv") o1 o2 o3 VMUL o1 o2 o3 -> pprPanic "RV64.pprInstr - VMUL wrong operands." (pprOps platform [o1, o2, o3]) - VQUOT o1 o2 o3 | allVectorRegOps [o1, o2, o3] -> op3 (text "\tvfdiv.vv") o1 o2 o3 - VQUOT o1 o2 o3 -> pprPanic "RV64.pprInstr - VQUOT wrong operands." (pprOps platform [o1, o2, o3]) + VQUOT (Just Signed) o1 o2 o3 | allIntVectorRegOps [o1, o2, o3] -> op3 (text "\tvdiv.vv") o1 o2 o3 + VQUOT (Just Unsigned) o1 o2 o3 | allIntVectorRegOps [o1, o2, o3] -> op3 (text "\tvdivu.vv") o1 o2 o3 + VQUOT Nothing o1 o2 o3 | allFloatVectorRegOps [o1, o2, o3] -> op3 (text "\tvfdiv.vv") o1 o2 o3 + VQUOT mbS o1 o2 o3 -> pprPanic ("RV64.pprInstr - VQUOT wrong operands. " ++ show mbS) (pprOps platform [o1, o2, o3]) VREM Signed o1 o2 o3 | allIntVectorRegOps [o1, o2, o3] -> op3 (text "\tvrem.vv") o1 o2 o3 VREM Unsigned o1 o2 o3 | allIntVectorRegOps [o1, o2, o3] -> op3 (text "\tvremu.vv") o1 o2 o3 VREM s o1 o2 o3 -> pprPanic ("RV64.pprInstr - VREM wrong operands. " ++ show s) (pprOps platform [o1, o2, o3]) @@ -870,6 +872,8 @@ pprInstr platform instr = case instr of VFMIN o1 o2 o3 -> pprPanic "RV64.pprInstr - VFMIN wrong operands." (pprOps platform [o1, o2, o3]) VFMAX o1 o2 o3 | allVectorRegOps [o1, o2, o3] -> op3 (text "\tvfmax.vv") o1 o2 o3 VFMAX o1 o2 o3 -> pprPanic "RV64.pprInstr - VFMAX wrong operands." (pprOps platform [o1, o2, o3]) + VRGATHER o1 o2 o3 | allVectorRegOps [o1, o2, o3] -> op3 (text "\tvrgatherei16.vv") o1 o2 o3 + VRGATHER o1 o2 o3 -> pprPanic "RV64.pprInstr - VRGATHER wrong operands." (pprOps platform [o1, o2, o3]) instr -> panic $ "RV64.pprInstr - Unknown instruction: " ++ instrCon instr where op1 op o1 = line $ op <+> pprOp platform o1 @@ -984,9 +988,9 @@ instrVecFormat platform instr = case instr of VMUL (OpReg fmt _reg) _o2 _o3 | isVecFormat fmt -> checkedJustFmt fmt VMUL _o1 _o2 _o3 -> pprPanic "Did not match" (pprInstr platform instr) - VQUOT (OpReg fmt _reg) _o2 _o3 + VQUOT _mbS (OpReg fmt _reg) _o2 _o3 | isVecFormat fmt -> checkedJustFmt fmt - VQUOT _o1 _o2 _o3 -> pprPanic "Did not match" (pprInstr platform instr) + VQUOT _mbS _o1 _o2 _o3 -> pprPanic "Did not match" (pprInstr platform instr) VSMIN (OpReg fmt _reg) _o2 _o3 | isVecFormat fmt -> checkedJustFmt fmt VSMIN _o1 _o2 _o3 -> pprPanic "Did not match" (pprInstr platform instr) @@ -1004,6 +1008,8 @@ instrVecFormat platform instr = case instr of VFMIN _o1 _o2 _o3 -> pprPanic "Did not match" (pprInstr platform instr) VFMAX (OpReg fmt _reg) _o2 _o3 -> checkedJustFmt fmt VFMAX _o1 _o2 _o3 -> pprPanic "Did not match" (pprInstr platform instr) + VRGATHER (OpReg fmt _reg) _o2 _o3 -> checkedJustFmt fmt + VRGATHER _o1 _o2 _o3 -> pprPanic "Did not match" (pprInstr platform instr) _ -> Nothing where checkedJustFmt :: Format -> Maybe Format View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a31e90c45ea723391dfd1e331ba0f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a31e90c45ea723391dfd1e331ba0f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109a] 4 commits: Specialise the (higher order) showSignedFloat
by Simon Peyton Jones (＠simonpj) 21 Apr '25

21 Apr '25

Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: 2bb593cc by Simon Peyton Jones at 2025-04-21T18:14:38+01:00 Specialise the (higher order) showSignedFloat - - - - - 61760473 by Simon Peyton Jones at 2025-04-21T18:15:16+01:00 Eta reduce augment and its rules ... to match foldr. I found this reduced some simplifer iterations - - - - - af0ef54b by Simon Peyton Jones at 2025-04-21T18:16:14+01:00 Try getting rid of this early-phase business - - - - - cba0eb2f by Simon Peyton Jones at 2025-04-21T18:16:45+01:00 Don't float PAPs to top level ...and treat case alternatives as strict contexts - - - - - 4 changed files: - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs Changes: ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -406,7 +406,7 @@ lvlApp env orig_expr ((_,AnnVar fn), args) , arity < n_val_args , Nothing <- isClassOpId_maybe fn = do { rargs' <- mapM (lvlNonTailMFE env False) rargs - ; lapp' <- lvlNonTailMFE env False lapp + ; lapp' <- lvlNonTailMFE env True lapp ; return (foldl' App lapp' rargs') } | otherwise @@ -707,16 +707,20 @@ lvlMFE env strict_ctxt ann_expr escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env) -- See Note [Floating to the top] + is_con_app = isSaturatedConApp expr saves_alloc = isTopLvl dest_lvl && (escapes_value_lam || floatConsts env) -- Always float allocation out of a value lambda -- if it gets to top level - && (not strict_ctxt || is_hnf || is_bot_lam) -{- - && ( (floatConsts env && - (not strict_ctxt || is_hnf)) -- (FT1) and (FT2) - || (is_bot_lam && escapes_value_lam)) -- (FT3) --} + && (not strict_ctxt || is_con_app || is_bot_lam) + -- is_con_app: don't float PAPs to the top; they may well end + -- up getting eta-expanded and re-inlined + -- E.g. f = \x -> (++) ys + -- If we float, then eta-expand we get + -- lvl = (++) ys + -- f = \x \zs -> lvl zs + -- and now wei'll inline lvl. Silly. + hasFreeJoin :: LevelEnv -> DVarSet -> Bool -- Has a free join point which is not being floated to top level. ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1466,7 +1466,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env , occ_int_cxt = int_cxt } = isNotTopLevel top_lvl -- Get rid of allocation || (int_cxt==IsInteresting) -- Function is applied - || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase + -- || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase one_occ OneOcc{ occ_n_br = 1 , occ_in_lam = IsInsideLam , occ_int_cxt = IsInteresting } @@ -1479,7 +1479,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env -- See Note [pre/postInlineUnconditionally in gentle mode] inline_prag = idInlinePragma bndr - early_phase = sePhase env /= FinalPhase +-- early_phase = sePhase env /= FinalPhase -- If we don't have this early_phase test, consider -- x = length [1,2,3] -- The full laziness pass carefully floats all the cons cells to ===================================== libraries/ghc-internal/src/GHC/Internal/Base.hs ===================================== @@ -1809,7 +1809,7 @@ build g = g (:) [] augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a] {-# INLINE [1] augment #-} -augment g xs = g (:) xs +augment g = g (:) {-# RULES "fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) . @@ -1975,7 +1975,7 @@ The rules for map work like this. "++/literal_utf8" forall x. (++) (unpackCStringUtf8# x) = unpackAppendCStringUtf8# x #-} {-# RULES -"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys +"++" [~1] forall xs. (++) xs = augment (\c n -> foldr c n xs) #-} ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -5,6 +5,7 @@ , MagicHash , UnboxedTuples , UnliftedFFITypes + , TypeApplications #-} {-# LANGUAGE CApiFFI #-} -- We believe we could deorphan this module, by moving lots of things @@ -1696,6 +1697,16 @@ showSignedFloat showPos p x = showParen (p > 6) (showChar '-' . showPos (-x)) | otherwise = showPos x + +-- Speicialise showSignedFloat for (a) the type and (b) the argument function +-- The particularly targets are the calls in `instance Show Float` and +-- `instance Show Double` +-- Specialising for both (a) and (b) is obviously more efficient; and if you +-- don't you find that the `x` argument is strict, but boxed, and that can cause +-- functions calling showSignedFloat to have box their argument. +{-# SPECIALISE showSignedFloat @Float showFloat #-} +{-# SPECIALISE showSignedFloat @Double showFloat #-} + {- We need to prevent over/underflow of the exponent in encodeFloat when called from scaleFloat, hence we clamp the scaling parameter. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6bee78af5db225c26bb21254bc9cc9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6bee78af5db225c26bb21254bc9cc9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

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

21 Apr '25

Serge S. Gulin pushed to branch wip/T24603 at Glasgow Haskell Compiler / GHC Commits: f50cbe59 by Serge S. Gulin at 2025-04-21T19:28:25+03:00 Bisect attempt for ghc js backend submodule - - - - - 1 changed file: - libraries/Cabal Changes: ===================================== libraries/Cabal ===================================== @@ -1 +1 @@ -Subproject commit 703582f80f6d7f0c914ef4b885affcfc7b7b6ec8 +Subproject commit 269fd808e5d80223a229b6b19edfe6f5b109007a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f50cbe59fbd77ff79cddee6d4c9c810… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f50cbe59fbd77ff79cddee6d4c9c810… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] 2 commits: Do not provide TIdentifierLParen paren twice
by Alan Zimmerman (＠alanz) 21 Apr '25

21 Apr '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: 7f35ad18 by Alan Zimmerman at 2025-04-21T16:24:44+01:00 Do not provide TIdentifierLParen paren twice - - - - - b5ae074e by Alan Zimmerman at 2025-04-21T17:07:28+01:00 Handle whitespace between identifier and '(' for directive only - - - - - 11 changed files: - 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/ParserM.hs - testsuite/tests/ghc-cpp/all.T - utils/check-cpp/Lexer.x - utils/check-cpp/Macro.hs - utils/check-cpp/ParsePP.hs - utils/check-cpp/ParserM.hs - utils/check-cpp/PreProcess.hs Changes: ===================================== compiler/GHC/Parser/PreProcess.hs ===================================== @@ -254,7 +254,7 @@ processCpp ss = do Right (CppDefine name args def) -> do ppDefine (MacroName name args) def Right (CppIf cond) -> do - val <- cppIf cond + val <- cppCond cond ar <- pushAccepting val acceptStateChange ar Right (CppIfdef name) -> do @@ -270,7 +270,7 @@ processCpp ss = do ar <- setAccepting (not accepting) acceptStateChange ar Right (CppElIf cond) -> do - val <- cppIf cond + val <- cppCond cond ar <- setAccepting val acceptStateChange ar Right CppEndif -> do ===================================== compiler/GHC/Parser/PreProcess/Lexer.x ===================================== @@ -2,11 +2,12 @@ module GHC.Parser.PreProcess.Lexer (lex_tok, lexCppTokenStream ) where import GHC.Parser.PreProcess.ParserM ( - St, init_pos, + St(..), init_pos, ParserM (..), Action, mkTv, Token(..), start_code, setStartCode, show_pos, position, - AlexInput(..), alexGetByte) + AlexInput(..), alexGetByte, + alexInputPrevChar) import qualified GHC.Parser.PreProcess.ParserM as ParserM (input) import Control.Monad import GHC.Prelude @@ -92,17 +93,20 @@ words :- <0> "xor" { mkTv TXor } <0> "xor_eq" { mkTv TXorEq } ---------------------------------------- - <0> [a-zA-Z_][a-zA-Z0-9_]*\( { mkTv TIdentifierLParen } - <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } - <0> \-? [0-9][0-9]* { mkTv TInteger } - <0> \" [^\"]* \" { mkTv (TString . tail . init) } - <0> () { begin other } + <0> [a-zA-Z_][a-zA-Z0-9_]*\( / { inDirective } { mkTv TIdentifierLParen } + <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } + <0> \-? [0-9][0-9]* { mkTv TInteger } + <0> \" [^\"]* \" { mkTv (TString . tail . init) } + <0> () { begin other } <other> .+ { \i -> do {setStartCode 0; mkTv TOther i} } { +inDirective :: AlexAccPred Bool +inDirective flag _ _ _ = flag + begin :: Int -> Action begin sc _str = do setStartCode sc @@ -110,7 +114,7 @@ begin sc _str = get_tok :: ParserM Token get_tok = ParserM $ \i st -> - case alexScan i (start_code st) of + case alexScanUser (scanning_directive st) i (start_code st) of AlexEOF -> Right (i, st, TEOF "") AlexError _ -> Left ("Lexical error at " ++ show_pos (position i)) AlexSkip i' _ -> case get_tok of ===================================== compiler/GHC/Parser/PreProcess/Macro.hs ===================================== @@ -1,6 +1,6 @@ module GHC.Parser.PreProcess.Macro ( -- process, - cppIf, + cppCond, -- get rid of warnings for tests m1, m2, @@ -46,8 +46,8 @@ import GHC.Prelude -- --------------------------------------------------------------------- -- We evaluate to an Int, which we convert to a bool -cppIf :: String -> PP Bool -cppIf str = do +cppCond :: String -> PP Bool +cppCond str = do s <- getPpState let expanded = expand (pp_defines s) str @@ -62,7 +62,7 @@ expand :: MacroDefines -> String -> String expand s str = expanded where -- TODO: repeat until re-expand or fixpoint - toks = case cppLex str of + toks = case cppLex False str of Left err -> error $ "expand:" ++ show (err, str) Right tks -> tks expanded = combineToks $ map t_str $ expandToks s toks @@ -81,7 +81,7 @@ doExpandToks ed _ [] = (ed, []) doExpandToks ed s (TIdentifierLParen n: ts) = -- TIdentifierLParen has no meaning here (only in a #define), so -- restore it to its constituent tokens - doExpandToks ed s (TIdentifier n:TOpenParen "(":ts) + doExpandToks ed s (TIdentifier (init n):TOpenParen "(":ts) doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest) -- See Note: [defined unary operator] below where @@ -268,13 +268,13 @@ isOther _ = True -- --------------------------------------------------------------------- m1 :: Either String [Token] -m1 = cppLex "`" +m1 = cppLex False "`" m2 :: Either String [Token] -m2 = cppLex "hello(5)" +m2 = cppLex False "hello(5)" m3 :: Either String [Token] -m3 = cppLex "#define FOO(m1,m2,m) ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == 7 && (m) <= 0)" +m3 = cppLex True "#define FOO(m1,m2,m) ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == 7 && (m) <= 0)" -- Right [THash {t_str = "#"} -- ,TDefine {t_str = "define"} @@ -290,12 +290,12 @@ m3 = cppLex "#define FOO(m1,m2,m) ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) = -- ] m4 :: Either String [Token] -m4 = cppLex "#if (m < 1)" +m4 = cppLex True "#if (m < 1)" m5 :: Either String (Maybe [[Token]], [Token]) m5 = do -- toks <- cppLex "(43,foo(a)) some other stuff" - toks <- cppLex "( ff(bar(),baz), 4 )" + toks <- cppLex False "( ff(bar(),baz), 4 )" return $ getExpandArgs toks tt :: Either String ([[Char]], [Char]) ===================================== compiler/GHC/Parser/PreProcess/ParsePP.hs ===================================== @@ -13,7 +13,7 @@ module GHC.Parser.PreProcess.ParsePP ( import Data.List (intercalate) import GHC.Parser.Errors.Ppr () import GHC.Parser.PreProcess.Lexer -import GHC.Parser.PreProcess.ParserM (Token (..), init_state) +import GHC.Parser.PreProcess.ParserM (Token (..), init_state, St(..)) import GHC.Parser.PreProcess.State import GHC.Prelude @@ -24,7 +24,7 @@ import GHC.Prelude -- | Parse a CPP directive, using tokens from the CPP lexer parseDirective :: String -> Either String CppDirective parseDirective s = - case cppLex s of + case cppLex True s of Left e -> Left e Right toks -> case toks of @@ -48,7 +48,7 @@ combineToks ss = intercalate " " ss cppDefine :: [Token] -> Either String CppDirective cppDefine [] = Left "error:empty #define directive" -cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine n args def +cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine (init n) args def where (args, def) = getArgs ts cppDefine (TIdentifier n : ts) = Right $ CppDefine n Nothing ts @@ -102,8 +102,9 @@ parseDefineArgs acc ts = Left $ "malformed macro args, expecting identifier foll -- --------------------------------------------------------------------- -cppLex :: String -> Either String [Token] -cppLex s = case lexCppTokenStream s init_state of +-- TODO: give this a better name +cppLex :: Bool -> String -> Either String [Token] +cppLex sd s = case lexCppTokenStream s (init_state {scanning_directive = sd}) of Left err -> Left err Right (_inp, _st, toks) -> Right toks @@ -141,4 +142,5 @@ t2 = doATest "# if ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == t3 :: Either String CppDirective t3 = parseDirective "# if FOO == 4" -t4 = cppLex "#define foo(X) X" +t4 :: Either String [Token] +t4 = cppLex True "#define foo(X) X" ===================================== compiler/GHC/Parser/PreProcess/ParserM.hs ===================================== @@ -8,10 +8,9 @@ module GHC.Parser.PreProcess.ParserM ( AlexInput (..), run_parser, -- Parser state - St, + St(..), init_state, StartCode, - start_code, setStartCode, -- Tokens Token (..), @@ -75,6 +74,7 @@ run_parser (ParserM f) = data St = St { start_code :: !StartCode , brace_depth :: !Int + , scanning_directive :: !Bool } deriving (Show) type StartCode = Int @@ -84,6 +84,7 @@ init_state = St { start_code = 0 , brace_depth = 0 + , scanning_directive = False } -- Tokens ===================================== testsuite/tests/ghc-cpp/all.T ===================================== @@ -9,8 +9,13 @@ def normalise_haskell_full_version( str ): def normalise_haskell_pl1( str ): return re.sub(r'__GLASGOW_HASKELL_PATCHLEVEL1__.*\n', '__GLASGOW_HASKELL_PATCHLEVEL1__ XXX', str) +# The MIN_VERSION_GLASGOW_HASKELL macro gets updated on every configure. +# Replace the RHS with a constant +def normalise_min_version_haskell( str ): + return re.sub(r'MIN_VERSION_GLASGOW_HASKELL.*\n', 'MIN_VERSION_GLASGOW_HASKELL XXX', str) + test('GhcCpp01', # normal, - [normalise_errmsg_fun(normalise_haskell_full_version, normalise_haskell_pl1)], + [normalise_errmsg_fun(normalise_haskell_full_version, normalise_haskell_pl1,normalise_min_version_haskell)], compile, ['-ddump-ghc-cpp -dkeep-comments']) ===================================== utils/check-cpp/Lexer.x ===================================== @@ -2,14 +2,16 @@ module Lexer (lex_tok, lexCppTokenStream ) where import ParserM ( - St, init_pos, + St(..), init_pos, ParserM (..), Action, mkTv, Token(..), start_code, setStartCode, show_pos, position, - AlexInput(..), alexGetByte) + AlexInput(..), alexGetByte, + alexInputPrevChar) -- import qualified ParserM as ParserM (input) import Control.Monad + -- The lexer is based on -- https://timsong-cpp.github.io/cppwp/n4140/lex.pptoken } @@ -90,17 +92,20 @@ words :- <0> "xor" { mkTv TXor } <0> "xor_eq" { mkTv TXorEq } ---------------------------------------- - <0> [a-zA-Z_][a-zA-Z0-9_]*\( { mkTv TIdentifierLParen } - <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } - <0> \-? [0-9][0-9]* { mkTv TInteger } - <0> \" [^\"]* \" { mkTv (TString . tail . init) } - <0> () { begin other } + <0> [a-zA-Z_][a-zA-Z0-9_]*\( / { inDirective } { mkTv TIdentifierLParen } + <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } + <0> \-? [0-9][0-9]* { mkTv TInteger } + <0> \" [^\"]* \" { mkTv (TString . tail . init) } + <0> () { begin other } <other> .+ { \i -> do {setStartCode 0; mkTv TOther i} } { +inDirective :: AlexAccPred Bool +inDirective flag _ _ _ = flag + begin :: Int -> Action begin sc _str = do setStartCode sc @@ -108,7 +113,7 @@ begin sc _str = get_tok :: ParserM Token get_tok = ParserM $ \i st -> - case alexScan i (start_code st) of + case alexScanUser (scanning_directive st) i (start_code st) of AlexEOF -> Right (i, st, TEOF "") AlexError _ -> Left ("Lexical error at " ++ show_pos (position i)) AlexSkip i' _ -> case get_tok of ===================================== utils/check-cpp/Macro.hs ===================================== @@ -1,6 +1,6 @@ module Macro ( -- process, - cppIf, + cppCond, -- get rid of warnings for tests -- m0, m1, @@ -45,8 +45,8 @@ import State -- --------------------------------------------------------------------- -- We evaluate to an Int, which we convert to a bool -cppIf :: String -> PP Bool -cppIf str = do +cppCond :: String -> PP Bool +cppCond str = do s <- getPpState let expanded = expand (pp_defines s) str @@ -61,7 +61,7 @@ expand :: MacroDefines -> String -> String expand s str = expanded where -- TODO: repeat until re-expand or fixpoint - toks = case cppLex str of + toks = case cppLex False str of Left err -> error $ "expand:" ++ show (err, str) Right tks -> tks expanded = combineToks $ map t_str $ expandToks s toks @@ -80,7 +80,7 @@ doExpandToks ed _ [] = (ed, []) doExpandToks ed s (TIdentifierLParen n: ts) = -- TIdentifierLParen has no meaning here (only in a #define), so -- restore it to its constituent tokens - doExpandToks ed s (TIdentifier n:TOpenParen "(":ts) + doExpandToks ed s (TIdentifier (init n):TOpenParen "(":ts) doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest) -- See Note: [defined unary operator] below where @@ -267,13 +267,13 @@ isOther _ = True -- --------------------------------------------------------------------- m1 :: Either String [Token] -m1 = cppLex "`" +m1 = cppLex False "`" m2 :: Either String [Token] -m2 = cppLex "hello(5)" +m2 = cppLex False "hello(5)" m3 :: Either String [Token] -m3 = cppLex "#define FOO(m1,m2,m) ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == 7 && (m) <= 0)" +m3 = cppLex True "#define FOO(m1,m2,m) ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == 7 && (m) <= 0)" -- Right [THash {t_str = "#"} -- ,TDefine {t_str = "define"} @@ -289,12 +289,12 @@ m3 = cppLex "#define FOO(m1,m2,m) ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) = -- ] m4 :: Either String [Token] -m4 = cppLex "#if (m < 1)" +m4 = cppLex True "#if (m < 1)" m5 :: Either String (Maybe [[Token]], [Token]) m5 = do -- toks <- cppLex "(43,foo(a)) some other stuff" - toks <- cppLex "( ff(bar(),baz), 4 )" + toks <- cppLex False "( ff(bar(),baz), 4 )" return $ getExpandArgs toks tt :: Either String ([[Char]], [Char]) ===================================== utils/check-cpp/ParsePP.hs ===================================== @@ -12,7 +12,7 @@ module ParsePP ( import Data.List import GHC.Parser.Errors.Ppr () import Lexer -import ParserM (Token (..), init_state) +import ParserM (Token (..), init_state, St(..)) import State -- import Debug.Trace @@ -24,7 +24,7 @@ import State -- | Parse a CPP directive, using tokens from the CPP lexer parseDirective :: String -> Either String CppDirective parseDirective s = - case cppLex s of + case cppLex True s of Left e -> Left e Right toks -> case toks of @@ -48,7 +48,7 @@ combineToks ss = intercalate " " ss cppDefine :: [Token] -> Either String CppDirective cppDefine [] = Left "error:empty #define directive" -cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine n args def +cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine (init n) args def where (args, def) = getArgs ts cppDefine (TIdentifier n : ts) = Right $ CppDefine n Nothing ts @@ -102,8 +102,9 @@ parseDefineArgs acc ts = Left $ "malformed macro args, expecting identifier foll -- --------------------------------------------------------------------- -cppLex :: String -> Either String [Token] -cppLex s = case lexCppTokenStream s init_state of +-- TODO: give this a better name +cppLex :: Bool -> String -> Either String [Token] +cppLex sd s = case lexCppTokenStream s (init_state {scanning_directive = sd}) of Left err -> Left err Right (_inp, _st, toks) -> Right toks @@ -141,4 +142,4 @@ t2 = doATest "# if ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == t3 :: Either String CppDirective t3 = parseDirective "# if FOO == 4" -t4 = cppLex "#define foo(X) X" +t4 = cppLex True "#define foo(X) X" ===================================== utils/check-cpp/ParserM.hs ===================================== @@ -8,7 +8,7 @@ module ParserM ( AlexInput (..), run_parser, -- Parser state - St, + St(..), init_state, StartCode, start_code, @@ -75,6 +75,7 @@ run_parser (ParserM f) = data St = St { start_code :: !StartCode , brace_depth :: !Int + , scanning_directive :: !Bool } deriving (Show) type StartCode = Int @@ -84,6 +85,7 @@ init_state = St { start_code = 0 , brace_depth = 0 + , scanning_directive = False } -- Tokens ===================================== utils/check-cpp/PreProcess.hs ===================================== @@ -281,7 +281,7 @@ processCpp ss = do Right (CppDefine name args def) -> do ppDefine (MacroName name args) def Right (CppIf cond) -> do - val <- cppIf cond + val <- cppCond cond ar <- pushAccepting val acceptStateChange ar Right (CppIfdef name) -> do @@ -297,7 +297,7 @@ processCpp ss = do ar <- setAccepting (not accepting) acceptStateChange ar Right (CppElIf cond) -> do - val <- cppIf cond + val <- cppCond cond ar <- setAccepting val acceptStateChange ar Right CppEndif -> do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/937a9c4d2a142d0c7a4f29ce8515d3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/937a9c4d2a142d0c7a4f29ce8515d3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

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

21 Apr '25

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

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] Process TIdentifierLParen
by Alan Zimmerman (＠alanz) 21 Apr '25

21 Apr '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: 937a9c4d by Alan Zimmerman at 2025-04-21T13:20:39+01:00 Process TIdentifierLParen Which only matters at the start of #define - - - - - 13 changed files: - 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 - utils/check-cpp/Eval.hs - utils/check-cpp/Lexer.x - utils/check-cpp/Macro.hs - utils/check-cpp/Main.hs - utils/check-cpp/ParsePP.hs - utils/check-cpp/Parser.y - utils/check-cpp/ParserM.hs - utils/check-cpp/State.hs Changes: ===================================== compiler/GHC/Parser/PreProcess/Lexer.x ===================================== @@ -92,10 +92,11 @@ words :- <0> "xor" { mkTv TXor } <0> "xor_eq" { mkTv TXorEq } ---------------------------------------- - <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } - <0> \-? [0-9][0-9]* { mkTv TInteger } - <0> \" [^\"]* \" { mkTv (TString . tail . init) } - <0> () { begin other } + <0> [a-zA-Z_][a-zA-Z0-9_]*\( { mkTv TIdentifierLParen } + <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } + <0> \-? [0-9][0-9]* { mkTv TInteger } + <0> \" [^\"]* \" { mkTv (TString . tail . init) } + <0> () { begin other } <other> .+ { \i -> do {setStartCode 0; mkTv TOther i} } ===================================== compiler/GHC/Parser/PreProcess/Macro.hs ===================================== @@ -71,14 +71,18 @@ expandToks :: MacroDefines -> [Token] -> [Token] expandToks s ts = let (expansionDone, r) = doExpandToks False s ts - in + in if expansionDone then expandToks s r else r doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token]) doExpandToks ed _ [] = (ed, []) -doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest) +doExpandToks ed s (TIdentifierLParen n: ts) = + -- TIdentifierLParen has no meaning here (only in a #define), so + -- restore it to its constituent tokens + doExpandToks ed s (TIdentifier n:TOpenParen "(":ts) +doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest) -- See Note: [defined unary operator] below where rest = case getExpandArgs ts of ===================================== compiler/GHC/Parser/PreProcess/ParsePP.hs ===================================== @@ -7,6 +7,7 @@ module GHC.Parser.PreProcess.ParsePP ( t1, t2, t3, + t4, ) where import Data.List (intercalate) @@ -47,9 +48,10 @@ combineToks ss = intercalate " " ss cppDefine :: [Token] -> Either String CppDirective cppDefine [] = Left "error:empty #define directive" -cppDefine (TIdentifier n : ts) = Right $ CppDefine n args def +cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine n args def where (args, def) = getArgs ts +cppDefine (TIdentifier n : ts) = Right $ CppDefine n Nothing ts cppDefine (t : _) = Left $ "#define: expecting an identifier, got :" ++ show t cppInclude :: [String] -> CppDirective @@ -79,14 +81,14 @@ cppDumpState _ts = CppDumpState -- --------------------------------------------------------------------- -- Crack out the arguments to a #define. This is of the form of --- comma-separated identifiers between parens +-- comma-separated identifiers between parens, where we have already +-- seen the opening paren. getArgs :: [Token] -> (Maybe [String], [Token]) getArgs [] = (Nothing, []) -getArgs (TOpenParen _ : ts) = +getArgs ts = case parseDefineArgs [] ts of Left err -> error err Right (args, rest) -> (Just (reverse args), rest) -getArgs ts = (Nothing, ts) parseDefineArgs :: [String] -> @@ -138,3 +140,5 @@ t2 = doATest "# if ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == t3 :: Either String CppDirective t3 = parseDirective "# if FOO == 4" + +t4 = cppLex "#define foo(X) X" ===================================== compiler/GHC/Parser/PreProcess/Parser.y ===================================== @@ -92,6 +92,7 @@ import GHC.Prelude 'xor_eq' { TXorEq {} } identifier { TIdentifier {} } + identifierLP { TIdentifierLParen {} } integer { TInteger {} } string { TString {} } other { TOther {} } ===================================== compiler/GHC/Parser/PreProcess/ParserM.hs ===================================== @@ -91,6 +91,7 @@ init_state = data Token = TEOF {t_str :: String} | TIdentifier {t_str :: String} + | TIdentifierLParen {t_str :: String} | TInteger {t_str :: String} | -- preprocessing-op-or-punc -- https://timsong-cpp.github.io/cppwp/n4140/lex.operators#nt:preprocessing-op… ===================================== utils/check-cpp/Eval.hs ===================================== @@ -8,7 +8,7 @@ eval :: Expr -> Int eval (Parens e) = eval e eval (Not e) = fromBool $ not (toBool $ eval e) -- eval (Var v) = error $ "need to look up :" ++ v -eval (Var v) = 0 -- Spec says remaining identifiers are replaces with zero +eval (Var _) = 0 -- Spec says remaining identifiers are replaces with zero eval (IntVal i) = i eval (Plus e1 e2) = (eval e1) + (eval e2) eval (Minus e1 e2) = (eval e1) - (eval e2) ===================================== utils/check-cpp/Lexer.x ===================================== @@ -90,10 +90,11 @@ words :- <0> "xor" { mkTv TXor } <0> "xor_eq" { mkTv TXorEq } ---------------------------------------- - <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } - <0> \-? [0-9][0-9]* { mkTv TInteger } - <0> \" [^\"]* \" { mkTv (TString . tail . init) } - <0> () { begin other } + <0> [a-zA-Z_][a-zA-Z0-9_]*\( { mkTv TIdentifierLParen } + <0> [a-zA-Z_][a-zA-Z0-9_]* { mkTv TIdentifier } + <0> \-? [0-9][0-9]* { mkTv TInteger } + <0> \" [^\"]* \" { mkTv (TString . tail . init) } + <0> () { begin other } <other> .+ { \i -> do {setStartCode 0; mkTv TOther i} } ===================================== utils/check-cpp/Macro.hs ===================================== @@ -70,13 +70,17 @@ expandToks :: MacroDefines -> [Token] -> [Token] expandToks s ts = let (expansionDone, r) = doExpandToks False s ts - in + in if expansionDone then expandToks s r else r doExpandToks :: Bool -> MacroDefines -> [Token] -> (Bool, [Token]) doExpandToks ed _ [] = (ed, []) +doExpandToks ed s (TIdentifierLParen n: ts) = + -- TIdentifierLParen has no meaning here (only in a #define), so + -- restore it to its constituent tokens + doExpandToks ed s (TIdentifier n:TOpenParen "(":ts) doExpandToks _ s (TIdentifier "defined" : ts) = (True, rest) -- See Note: [defined unary operator] below where ===================================== utils/check-cpp/Main.hs ===================================== @@ -280,6 +280,7 @@ t2 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 5 @@ -348,6 +349,7 @@ t4 = do , "#else" , "x = \"no version\"" , "#endif" + , "" ] -- x = "got version" @@ -399,6 +401,7 @@ t10 = do , "#else" , "x = 2" , "#endif" + , "" ] -- x = 1 @@ -424,6 +427,7 @@ t11 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 1 @@ -438,6 +442,7 @@ t12 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 1 @@ -450,6 +455,7 @@ t13 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 1 @@ -473,6 +479,7 @@ t14 = do , "#else" , "z = 5" , "#endif" + , "" ] -- x = 1 @@ -496,6 +503,7 @@ t16 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 1 @@ -509,6 +517,7 @@ t17 = do , "#else" , "x = 5" , "#endif" + , "" ] -- x = 1 @@ -525,6 +534,7 @@ t18 = do , "#else" , "x = 5" , "#endif" + , "" ] t19 :: IO () @@ -593,6 +603,7 @@ t22 = do , "also ignored" , "#endif" , "#endif" + , "" ] t23 :: IO () @@ -606,6 +617,7 @@ t23 = do , "#else" , "x = 2" , "#endif" + , "" ] t24 :: IO () @@ -619,6 +631,7 @@ t24 = do , "#else" , "x = 2" , "#endif" + , "" ] t25 :: IO () @@ -632,6 +645,7 @@ t25 = do , "#else" , "x = 2" , "#endif" + , "" ] t26 :: IO () @@ -662,6 +676,7 @@ t27 = do , "#ifdef DEBUG" , " hiding (rev)" , "#endif" + , "" ] t28 :: IO () ===================================== utils/check-cpp/ParsePP.hs ===================================== @@ -48,9 +48,10 @@ combineToks ss = intercalate " " ss cppDefine :: [Token] -> Either String CppDirective cppDefine [] = Left "error:empty #define directive" -cppDefine (TIdentifier n : ts) = Right $ CppDefine n args def +cppDefine (TIdentifierLParen n : ts) = Right $ CppDefine n args def where (args, def) = getArgs ts +cppDefine (TIdentifier n : ts) = Right $ CppDefine n Nothing ts cppDefine (t : _) = Left $ "#define: expecting an identifier, got :" ++ show t cppInclude :: [String] -> CppDirective @@ -80,14 +81,14 @@ cppDumpState _ts = CppDumpState -- --------------------------------------------------------------------- -- Crack out the arguments to a #define. This is of the form of --- comma-separated identifiers between parens +-- comma-separated identifiers between parens, where we have already +-- seen the opening paren. getArgs :: [Token] -> (Maybe [String], [Token]) getArgs [] = (Nothing, []) -getArgs (TOpenParen _ : ts) = +getArgs ts = case parseDefineArgs [] ts of Left err -> error err Right (args, rest) -> (Just (reverse args), rest) -getArgs ts = (Nothing, ts) parseDefineArgs :: [String] -> @@ -139,3 +140,5 @@ t2 = doATest "# if ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == t3 :: Either String CppDirective t3 = parseDirective "# if FOO == 4" + +t4 = cppLex "#define foo(X) X" ===================================== utils/check-cpp/Parser.y ===================================== @@ -91,6 +91,7 @@ import qualified GHC.Internal.Data.Tuple as Happy_Prelude 'xor_eq' { TXorEq {} } identifier { TIdentifier {} } + identifierLP { TIdentifierLParen {} } integer { TInteger {} } string { TString {} } other { TOther {} } ===================================== utils/check-cpp/ParserM.hs ===================================== @@ -91,6 +91,7 @@ init_state = data Token = TEOF {t_str :: String} | TIdentifier {t_str :: String} + | TIdentifierLParen {t_str :: String} | TInteger {t_str :: String} | -- preprocessing-op-or-punc -- https://timsong-cpp.github.io/cppwp/n4140/lex.operators#nt:preprocessing-op… ===================================== utils/check-cpp/State.hs ===================================== @@ -191,7 +191,7 @@ setAccepting on = do let possible_accepting = parent_on && on let (new_group_state, accepting) = case (group_state, possible_accepting) of - (PpNoGroup, v) -> error "setAccepting for state PpNoGroup" + (PpNoGroup, _) -> error "setAccepting for state PpNoGroup" (PpInGroupStillInactive, True) -> (PpInGroupHasBeenActive, True) (PpInGroupStillInactive, False) -> (PpInGroupStillInactive, False) (PpInGroupHasBeenActive, _) -> (PpInGroupHasBeenActive, False) @@ -317,7 +317,7 @@ addDefine name def = do addDefine' :: PpState -> MacroName -> MacroDef -> PpState addDefine' s name def = - s{pp_defines = insertMacroDef name def (pp_defines s)} + s{ pp_defines = insertMacroDef name def (pp_defines s)} ppDefine :: MacroName -> MacroDef -> PP () ppDefine name val = addDefine name val View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/937a9c4d2a142d0c7a4f29ce8515d34… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/937a9c4d2a142d0c7a4f29ce8515d34… You're receiving this email because of your account on gitlab.haskell.org.

1 0