- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/ani/precise-fun-loc
by Apoorv Ingle (＠ani) 02 Apr '26

02 Apr '26

Apoorv Ingle pushed new branch wip/ani/precise-fun-loc at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ani/precise-fun-loc You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: Streamline expansions using HsExpansion (#25001)
by Marge Bot (＠marge-bot) 02 Apr '26

02 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 58009c14 by Apoorv Ingle at 2026-04-02T09:51:24+01:00 Streamline expansions using HsExpansion (#25001) Notes added [Error Context Stack] [Typechecking by expansion: overview] Notes updated Note [Expanding HsDo with XXExprGhcRn] [tcApp: typechecking applications] ------------------------- Metric Decrease: T9020 ------------------------- There are 2 key changes: 1. `HsExpand` datatype mediates between expansions 2. Replace `ErrCtxtM` to a simpler `HsCtxt` that does not depend on a `TidyEnv` This has some consequences detailed below: 1. `HsExpand` datatype mediates between expansions * Simplifies the implementations of `tcExpr` to work on `XExpr` * Removes `VACtxt` (and its associated `VAExpansion` and `VACall`) datatype, it is subsumed by simply a `SrcSpan`. * Removes the function `addHeadCtxt` as it is now mearly setting a location * The function `tcValArgs` does its own argument number management * move `splitHsTypes` out of `tcApp` * Removes special case of tcBody from `tcLambdaMatches` * Removes special case of `dsExpr` for `ExpandedThingTc` * Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr` * Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span` * Remove `PopErrCtxt` from `XXExprGhcRn` * `fun_orig` in tcInstFun depends on the SrcSpan of the head of the application chain (similar to addArgCtxt) - it references the application chain head if it is user located, or uses the error context stack as a fallback if it's a generated location * Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes - Expressions wrapped around `GeneratedSrcSpan` are ignored and never added to the error context stack - In Explicit list expansion `fromListN` is wrapped with a `GeneratedSrcSpan` with `GeneratedSrcSpanDetails` field to store the original srcspan 2. Replace `ErrCtxtM` to a simpler `HsCtxt` that does not depend on a `TidyEnv` * Merge `HsThingRn` to `HsCtxt` * Landmark Error messages are now just computed on the fly * Make HsExpandedRn and HsExpandedTc payload a located HsExpr GhcRn * `HsCtxt` are tidied and zonked at the end right before printing Co-authored-by: simonpj <simon.peytonjones(a)gmail.com> - - - - - 9d964ec9 by Zubin Duggal at 2026-04-02T16:15:51-04:00 driver: recognise .dyn_o as a valid object file to link if passed on the command line. This allows plugins compiled with this suffix to run. Fixes #24486 - - - - - 117f299b by Simon Jakobi at 2026-04-02T16:15:54-04:00 Add regression test for #16145 Closes #16145. - - - - - 87807fc2 by Matthew Pickering at 2026-04-02T16:15:55-04:00 bytecode: Add magic header/version to bytecode files In order to avoid confusing errors when using stale interface files (ie from an older compiler version), we add a simple header/version check like the one for interface files. Fixes #27068 - - - - - 2d653e6a by fendor at 2026-04-02T16:15:55-04:00 Add constants for bytecode in-memory buffer size Introduce a common constant for the default size of the .gbc and .bytecodelib binary buffer. The buffer is by default set to 1 MB. - - - - - e28fd7fc by Duncan Coutts at 2026-04-02T16:15:56-04:00 Add a rts posix FdWakup utility module This will be used to implement wakeupIOManager for in-RTS I/O managers. It provides a notification/wakeup mechanism using FDs, suitable for situations when a thread is blocked on a set of fds anyway. It uses the classic self-pipe trick, or equivalently eventfd on supported platforms. This will initially be used to implement prompt interrupt or shutdown of the posix ticker thread. - - - - - 85199690 by Duncan Coutts at 2026-04-02T16:15:56-04:00 Add prompt shutdown to the pthread ticker implementation. The Linux timerfd ticker monitors a pipe which is used by exitTicker to ensure a prompt wakeup and shutdown. The pthread ticker lacked this and so would only exit at the next ticker wakeup (10ms by default). This patch adds the same mechanism to the pthread ticker. This changes the pthread ticker from waiting by using nanosleep() to waiting using either ppoll() or select(), so that it can wait on both a time and a file descriptor. On Linux at least, a test program to compare the timing jitter of these APIs shows that using nanpsleep, ppoll or select makes no statistical difference to the maximum or average jitter. This is a step towards unifying the posix ticker implementations, so that we can have just one portable one (albeit with some limited cpp). It is also a step towards using the ticker as part of a more general implementation of wakeUpRts, since this will require a method to wake the rts from a signal handler context (ctl-c handler). - - - - - bd6e5d21 by Duncan Coutts at 2026-04-02T16:15:56-04:00 Update ticker header commentary It was antique and didn't apply even to the previous implementation, and certainly not to the updated one. - - - - - 4286c294 by Duncan Coutts at 2026-04-02T16:15:56-04:00 Remove the timerfd-based ticker implementation There does not appear to be any remaining advantage on Linux to using the timerfd ticker implementation over the portable one (using ppoll on Linux for precise timing). The eventfd implementation was originally added at a time when Linux was still using a signal based implementation. So it made sense at the time. See (closed) issue #10840. - - - - - 6bf4326a by Duncan Coutts at 2026-04-02T16:15:56-04:00 Consolidate to a single posix ticker implementation Previously we had four implementations, two using signals and two using threads. Having just one should make behaviour more consistent between platforms, and should make maintenance easier. - - - - - 93344577 by mangoiv at 2026-04-02T16:15:57-04:00 issue template: fix add bug label - - - - - 5c57fa5f by Sylvain Henry at 2026-04-02T16:16:28-04:00 Add more canned GC functions for common register patterns (#27142) Based on analysis of heap-check sites across the GHC compiler and Cabal, the following patterns were not covered by existing canned GC functions but occurred frequently enough to warrant specialisation: stg_gc_ppppp -- 5 GC pointers stg_gc_ip -- unboxed word + GC pointer stg_gc_pi -- GC pointer + unboxed word stg_gc_ii -- two unboxed words stg_gc_bpp -- byte (I8) + two GC pointers Adding these reduces the fraction of heap-check sites falling back to the generic GC path from ~1.4% to ~0.4% when compiling GHC itself. Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 142 changed files: - .gitlab/issue_templates/default.md - compiler/GHC.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Expr.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/StgToCmm/Heap.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Do.hs - + compiler/GHC/Tc/Gen/Expand.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs-boot - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Error.hs - + compiler/GHC/Types/Error.hs-boot - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SrcLoc.hs - + compiler/GHC/Unit/State.hs-boot - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Logger.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - rts/HeapStackCheck.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h - + rts/posix/FdWakeup.c - + rts/posix/FdWakeup.h - rts/posix/Ticker.c - − rts/posix/ticker/Pthread.c - − rts/posix/ticker/TimerFd.c - rts/rts.cabal - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/driver/bytecode-object/Makefile - testsuite/tests/driver/bytecode-object/all.T - testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - testsuite/tests/monadfail/MonadFailErrors.stderr - testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr - testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr - testsuite/tests/plugins/Makefile - + testsuite/tests/plugins/T24486-plugin/Makefile - + testsuite/tests/plugins/T24486-plugin/Setup.hs - + testsuite/tests/plugins/T24486-plugin/T24486-plugin.cabal - + testsuite/tests/plugins/T24486-plugin/T24486_Plugin.hs - + testsuite/tests/plugins/T24486.hs - + testsuite/tests/plugins/T24486_Helper.hs - testsuite/tests/plugins/all.T - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/printer/T17697.stderr - testsuite/tests/profiling/should_run/callstack001.stdout - testsuite/tests/rebindable/rebindable6.stderr - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - testsuite/tests/runghc/Makefile - + testsuite/tests/runghc/T16145.hs - + testsuite/tests/runghc/T16145.stdout - + testsuite/tests/runghc/T16145_aux.hs - testsuite/tests/runghc/all.T - + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T7857.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail140.stderr - testsuite/tests/typecheck/should_fail/tcfail181.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82c991ca1ea5fa9c70a3f7986af9ab… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82c991ca1ea5fa9c70a3f7986af9ab… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/jeltsch/more-efficient-home-module-finding
by Wolfgang Jeltsch (＠jeltsch) 02 Apr '26

02 Apr '26

Wolfgang Jeltsch pushed new branch wip/jeltsch/more-efficient-home-module-finding at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/jeltsch/more-efficient-home-m… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26878] Simplify mkTick
by sheaf (＠sheaf) 02 Apr '26

02 Apr '26

sheaf pushed to branch wip/T26878 at Glasgow Haskell Compiler / GHC Commits: e0a32431 by sheaf at 2026-04-02T22:12:24+02:00 Simplify mkTick This commit simplifies 'GHC.Core.Utils.mkTick', removing the accumulating parameter 'rest' which was suspiciously treating a bunch of different ticks as a group, and moving the group as a whole around the AST, ignoring that the ticks in the group might have different placement properties. Also adds Note [Pushing SCCs inwards] which clarifies the logic for pushing SCCs into lambdas, constructor applications, and dropping SCCs around non-function variables (in particular the treatment of splittable ticks). A few other changes are also implemented: - simplify 'can_split' predicate (no functional change) - drop profiling ticks around coercions, fixing #26941 and #27121 - combine profiling ticks into one when possible Fixes #26878, #26941 and #27121 Co-authored-by: simonpj <simon.peytonjones(a)gmail.com> - - - - - 9 changed files: - compiler/GHC/Core/Utils.hs - compiler/GHC/Types/Tickish.hs - libraries/ghc-heap/tests/tso_and_stack_closures.hs - + testsuite/tests/profiling/should_compile/T27121.hs - + testsuite/tests/profiling/should_compile/T27121_aux.hs - testsuite/tests/profiling/should_compile/all.T - + testsuite/tests/simplCore/should_compile/T26941.hs - + testsuite/tests/simplCore/should_compile/T26941_aux.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -303,101 +303,262 @@ mkCast expr co * * ********************************************************************* -} --- | Wraps the given expression in the source annotation, dropping the --- annotation if possible. +-- | Wraps the given expression in a Tick, floating the tick as far into +-- the AST as possible in order to try to satisfy the tick's desired placement +-- properties (as per Note [Tickish placement] in GHC.Types.Tickish). +-- +-- Prefer using 'mkTick' over explicit use of the 'Tick' constructor. +-- +-- Also performs small on-the-fly optimisations: +-- +-- * Eliminate unnecessary ticks by either absorbing them into existing ones +-- or dropping them if that is valid (e.g. dropping profiling ticks around +-- types, coercions and literals). +-- * Split profiling ticks into counting/scoping parts so that the two parts +-- can be placed independently into the AST. mkTick :: CoreTickish -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' id orig_expr +mkTick t orig_expr = mkTick' orig_expr where -- Some ticks (cost-centres) can be split in two, with the -- non-counting part having laxer placement properties. - canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + -- See Note [Scoping ticks and counting ticks] in GHC.Types.Tickish. + can_split = tickishCanSplit t - -- mkTick' handles floating of ticks *into* the expression. - mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with) - -- Always a composition of (Tick t) wrappers - -> CoreExpr -- Current expression - -> CoreExpr - -- So in the call (mkTick' rest e), the expression - -- (rest e) - -- has the same type as e - -- Returns an expression equivalent to (Tick t (rest e)) - mkTick' rest expr = case expr of - -- Float ticks into unsafe coerce the same way we would do with a cast. - Case scrut bndr ty alts@[Alt ac abs _rhs] - | Just rhs <- isUnsafeEqualityCase scrut bndr alts - -> Case scrut bndr ty [Alt ac abs (mkTick' rest rhs)] - - -- Cost centre ticks should never be reordered relative to each - -- other. Therefore we can stop whenever two collide. + -- mkTick' handles floating of tick `t` *into* the expression. + mkTick' :: CoreExpr -> CoreExpr + mkTick' expr = case expr of Tick t2 e - | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr - - -- Otherwise we assume that ticks of different placements float - -- through each other. - | tickishPlace t2 /= tickishPlace t -> Tick t2 $ mkTick' rest e - - -- For annotations this is where we make sure to not introduce - -- redundant ticks. - | tickishContains t t2 -> mkTick' rest e -- Drop t2 - | tickishContains t2 t -> rest e -- Drop t - | otherwise -> mkTick' (rest . Tick t2) e - - -- Ticks don't care about types, so we just float all ticks - -- through them. Note that it's not enough to check for these - -- cases top-level. While mkTick will never produce Core with type - -- expressions below ticks, such constructs can be the result of - -- unfoldings. We therefore make an effort to put everything into - -- the right place no matter what we start with. - Cast e co -> mkCast (mkTick' rest e) co - Coercion co -> Tick t $ rest (Coercion co) + + -- Common up ticks when possible, including profiling ticks that + -- share a cost centre and source notes that subsume one another. + | Just t' <- combineTickish_maybe t t2 + -> mkTick t' e + + -- Profiling ticks for different cost centres should never be reordered + -- relative to each other. Therefore, we stop whenever two collide. + | ProfNote {} <- t + , ProfNote {} <- t2 + -> Tick t expr + + -- Ticks of different placements float through each other, so that each + -- tick can be floated into its expected position in the AST. + -- See Note [Tickish placement] in GHC.Types.Tickish. + | tickishPlace t2 /= tickishPlace t + -> Tick t2 $ mkTick' e Lam x e -- Always float through type lambdas. Even for non-type lambdas, -- floating is allowed for all but the most strict placement rule. | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime - -> Lam x $ mkTick' rest e + -> Lam x $ mkTick' e - -- If it is both counting and scoped, we split the tick into its - -- two components, often allowing us to keep the counting tick on - -- the outside of the lambda and push the scoped tick inside. - -- The point of this is that the counting tick can probably be - -- floated, and the lambda may then be in a position to be - -- beta-reduced. - | canSplit - -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + -- Push SCCs into lambdas. + -- See (PSCC2) in Note [Pushing SCCs inwards]. + | can_split + -> Tick (mkNoScope t) $ Lam x $ mkTick (mkNoCount t) e App f arg - -- Always float through type applications. + -- All ticks float inwards through non-runtime arguments, as per + -- Note [Tickish placement] in GHC.Types.Tickish. | not (isRuntimeArg arg) - -> App (mkTick' rest f) arg + -> App (mkTick' f) arg - -- We can also float through constructor applications, placement - -- permitting. Again we can split. - | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) + -- Push SCCs into saturated constructor applications. + -- See (PSCC3) in Note [Pushing SCCs inwards]. + | isSaturatedConApp expr + , tickishPlace t == PlaceCostCentre || can_split -> if tickishPlace t == PlaceCostCentre - then rest $ tickHNFArgs t expr - else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + then tickHNFArgs t expr + else Tick (mkNoScope t) $ tickHNFArgs (mkNoCount t) expr + + -- See Note [No ticks around types or coercions] + e@(Coercion {}) -> e + e@(Type {}) -> e + -- Don't wrap static data in a tick which compiles to code, + -- as the code will never be run. + e@(Lit {}) | tickishIsCode t -> e + + -- All ticks can be floated through casts, as per Note [Tickish placement]. + Cast e co -> mkCast (mkTick' e) co + + -- Treat 'unsafeCoerce' as if it was a cast: float all ticks inwards. + -- See Note [Push ticks into unsafeCoerce] + Case scrut bndr ty alts@[Alt ac abs _rhs] + | Just rhs <- isUnsafeEqualityCase scrut bndr alts + -> Case scrut bndr ty [Alt ac abs (mkTick' rhs)] Var x - | notFunction && tickishPlace t == PlaceCostCentre - -> rest expr -- Drop t - | notFunction && canSplit - -> Tick (mkNoScope t) $ rest expr - where - -- SCCs can be eliminated on variables provided the variable - -- is not a function. In these cases the SCC makes no difference: - -- the cost of evaluating the variable will be attributed to its - -- definition site. When the variable refers to a function, however, - -- an SCC annotation on the variable affects the cost-centre stack - -- when the function is called, so we must retain those. - notFunction = not (isFunTy (idType x)) - - Lit{} + -- Don't drop any ticks around a function + | isFunTy (idType x) + -> Tick t expr + -- Drop SCCs around non-function variables. + -- See (PSCC1) in Note [Pushing SCCs inwards]. | tickishPlace t == PlaceCostCentre - -> rest expr -- Drop t + -> -- Drop pure SCC ticks: scc<foo> (x :: Int) ==> x + expr + | can_split + -> -- Drop the scoping part of the tick, but keep the counting part. + Tick (mkNoScope t) expr + + -- Catch-all: annotate where we stand. + -- In particular (but not only): Let, most Cases. + _other -> Tick t expr + +{- Note [Pushing SCCs inwards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Amongst all ticks, SCCs have the laxest placement properties (PlaceCostCentre, +as described in Note [Tickish placement] GHC.Types.Tickish): + + (PSCC1) SCCs around non-function variables can be eliminated. + The cost of evaluating the variable will be attributed to its definition + site, so the SCC makes no difference. Example: + + scc<foo> (x :: Int) ==> x + + NB: this is only valid when the variable is not a function. For example, in: + + scc<foo> (f :: Int -> Int) + + we must retain the cost centre annotation, as it affects the cost-centre + pointer when the function is called. Discarding the SCC in this case would + defeat the profiling mechanism entirely! + + (PSCC2) SCCs can be pushed into lambdas. + + scc<foo> (\x -> e) ==> \x -> scc<foo> e + + (PSCC3) We can push SCCs into (saturated) constructor applications. + For example, for an arity 2 data constructor 'D': + + scc<foo> (D e1 e2) ==> D (scc<foo> e1) (scc<foo> e2) + +Now, two kinds of ticks contain SCCs: + + - bare SCCs (i.e. ProfNote with profNoteCounts = False, profNoteScopes = True) + - profiling ticks that both count and scope + +The above explanation deals with bare SCCs. When handling profiling ticks that +both count and scope, we can split tick into two, so that the scoping part can +be pushed inwards (or even discarded). Specifically, we perform the following +transformations: + + (PSCC1) Drop the SCC around non-function variables, keeping only the counting + part: + + scctick<foo> (x :: Int) ==> tick<foo> x + + (PSCC2) Push the SCC inside lambdas: + + scctick<foo> (\x. e) ==> tick<foo> (\x. scc<foo> e) + + NB: we must keep the counting part outside the lambda, in order to preserve + tick counter tallies – it would not be sound to push the counting part inside. - -- Catch-all: Annotate where we stand - _any -> Tick t $ rest expr + (PSCC3) Push the SCC inside saturated contructor applications. + + scctick<foo> (D e1 e2) ==> tick<foo> (D (scc<foo> e1) (scc<foo> e2)) + +The benefit of these transformation is that the counting part, tick<foo>, can +likely be floated out of the way, which may expose additional optimisation +opportunities. For example, for (PSCC2): + + (scctick<foo> (\x. e)) arg + + ==>{PSCC2} + + (tick<foo> (\x. scc<foo> e)) arg + + ==>{GHC.Core.Opt.FloatOut.floatExpr, because 'tick<foo>' has no scope} + + tick<foo> ((\x. scc<foo> e) arg) + + ==>{beta reduction} + + tick<foo> (let x = arg in scc<foo> e) + +For (PSCC3): + + case (scctick<foo> (Just x)) of { Nothing -> 0; Just y -> y + 1 } + + ==>{PSCC3} + + case (tick<foo> (Just (scc<foo> x))) of { Nothing -> 0; Just y -> y + 1 } + + ==>{GHC.Core.Opt.FloatOut.floatExpr, because 'tick<foo>' has no scope} + + tick<foo> (case Just (scc<foo> x) of { Nothing -> 0; Just y -> y + 1 }) + + ==>{case of known constructor} + + tick<foo> (let y = scc<foo> x in y + 1) + +Note [Push ticks into unsafeCoerce] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #25212, we had a program of the form: + + data Box = Box Any + asBox :: a -> Box + asBox x = {-# SCC asBox #-} Box (unsafeCoerce x) + +As per Note [Implementing unsafeCoerce] in GHC.Internal.Unsafe.Coerce, the call +to `unsafeCoerce` turns into + + case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> x |> Sub co + +The worker for 'asBox' is then of the form: + + $wasBox = \@a (x :: a) -> + (# case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> x |> Sub co + #) + +When inserting the SCC, we push it into the constructor as per (PSCC3) in +Note [Pushing SCCs inwards], so we get: + + $wasBox = \@a (x :: a) -> + tick<asBox> + (# scc<asBox> + case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> x |> Sub co + #) + +Now, if we don't push the SCC tick into the case statement, Core Prep will +see an expression like 'MkSolo# (scc<asBox> ...)', which it will ANFise to +'let x = scc<asBox> ... in MkSolo# x', creating an unwanted thunk in the process. + +So the strategy is to treat this 'unsafeEqualityProof' case statement as if it +was a cast. We thus push the SCC into the RHS of the pattern match: + + $wasBox = \@a (x :: a) -> + tick<asBox> + (# case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> scc<asBox> x |> Sub co + #) + +Then the SCC completely evaporates, as per (PSCC1) in Note [Pushing SCCs inwards]. + +Note [No ticks around types or coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It doesn't make much sense to put a tick around a type or a coercion, as both +types and coercions are erased in the end. + +In fact, it is quite dangerous to add a tick around types or coercions, because +the optimiser does not robustly look through ticks: + + - 'GHC.Core.SimpleOpt.simple_bind_pair' does not look through ticks when + looking at the RHS to decide whether it is a Type or Coercion, + - 'GHC.Core.Opt.Simplify.Iteration.completeBind' does not look through ticks + when looking at the RHS of an CoVar binding. + +This means it is vital to drop ticks around types/coercions: + + - (#26941) Core Lint rejects bindings of the form "let co = tick ..." + in which the LHS is a CoVar and the RHS is a ticked Coercion. + - (#27121) The simplifier mis-handles ticked coercion bindings, which can + result in 'lookupIdSubst' panics (due to failing to extend the substitution + with a coercion). +-} mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks @@ -2545,8 +2706,8 @@ exprIsTickedString = isJust . exprIsTickedString_maybe exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString exprIsTickedString_maybe (Lit (LitString bs)) = Just bs exprIsTickedString_maybe (Tick t e) - -- we don't tick literals with CostCentre ticks, compare to mkTick - | tickishPlace t == PlaceCostCentre = Nothing + -- Shortcut: ticks with code never wrap literals (compare with 'mkTick') + | tickishIsCode t = Nothing | otherwise = exprIsTickedString_maybe e exprIsTickedString_maybe _ = Nothing ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -17,6 +17,7 @@ module GHC.Types.Tickish ( TickishPlacement(..), tickishPlace, tickishContains, + combineTickish_maybe, -- * Breakpoint tick identifiers BreakpointId(..), BreakTickIndex @@ -261,8 +262,12 @@ Ticks have two independent attributes: See Note [Scoped ticks] +Note that profiling notes which both count and scope can be split into two +separate ticks, one that counts and doesn't scope and one that scopes and doesn't +count; see 'tickishCanSplit', 'mkNoCount' and 'mkNoScope'. + Note [Counting ticks] -~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~ The following ticks count: - ProfNote ticks with profNoteCounts = True - HPC ticks @@ -290,7 +295,7 @@ sharing, so in practice the actual number of ticks may vary, except that we never change the value from zero to non-zero or vice-versa. Note [Scoped ticks] -~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~ The following ticks are scoped: - ProfNote ticks with profNoteScope = True - Breakpoints @@ -375,6 +380,61 @@ Whether we are allowed to float in additional cost depends on the tick: While these transformations are legal, we want to make a best effort to only make use of them where it exposes transformation opportunities. + +Note [Tickish placement] +~~~~~~~~~~~~~~~~~~~~~~~~ +The placement behaviour of ticks (i.e. which nodes we want the tick to be placed +around in the AST) is governed by 'TickishPlacement'. +From most restrictive to least restrictive placement rules: + + - PlaceRuntime: counting ticks. + + Ticks with 'PlaceRuntime' placement want to be placed around run-time + expressions. They can be moved through pure compile-time constructs such as + other type arguments, casts, or type lambdas: + + tick <t> (f @ty) ==> (tick <t> f) @ty + tick <t> (e |> co) ==> (tick <t> e) |> co + tick <t> (/\a. e) ==> /\a. tick <t> e + + This is the most restrictive placement rule for ticks, as all tickishs have + in common that they want to track runtime behaviour. + + Any tick that counts (see Note [Counting ticks]) has 'PlaceRuntime' placement. + + - PlaceNonLam: source notes. + + Like PlaceRuntime, but we can also float the tick through value lambdas: + + tick <t> (\x. e) ==> \x. tick <t> e + + This makes sense where there is little difference between annotating the + lambda and annotating the lambda's code. + + - PlaceCostCentre: non-counting profiling ticks. + + In addition to floating through lambdas, cost-centre style tickishs can be + pushed into (saturated) constructor applications, and can be eliminated when + placed around non-function variables: + + tick <t> (C e1 e2) ==> C (tick <t> e1) (tick <t> e2) + + tick <t> (x :: Int) ==> (x :: Int) + + Neither the constructor application nor the variable 'x' are likely to have + any cost worth mentioning. + +We generally try to push ticks inwards until they end up placed around a Core +expression that is appropriate for their placement rule, as described above. +This gives us the opportunity to eliminate the tick, either by combining it with +another tick (see 'combineTickish_maybe') or by dropping it altogether. For +example, a (non-counting) SCC around a non-function variable can be dropped, as +there is no cost to scope over. + +After the tick has been placed by 'mkTick', the simplifier may later (during +simplification) decide to float it outwards (see e.g. GHC.Core.Opt.Simplify.Iteration.simplTick). +The story here is not fully worked out, as the simplifier calls 'mkTick', which +might push the tick inwards again. -} -- | Returns @True@ for ticks that can be floated upwards easily even @@ -441,35 +501,19 @@ isProfTick _ = False -- annotating for example using @mkTick@. If we find that we want to -- put a tickish on an expression ruled out here, we try to float it -- inwards until we find a suitable expression. +-- +-- See Note [Tickish placement]. data TickishPlacement = - -- | Place ticks exactly on run-time expressions. We can still - -- move the tick through pure compile-time constructs such as - -- other ticks, casts or type lambdas. This is the most - -- restrictive placement rule for ticks, as all tickishs have in - -- common that they want to track runtime processes. The only - -- legal placement rule for counting ticks. - -- NB: We generally try to move these as close to the relevant - -- runtime expression as possible. This means they get pushed through - -- tyoe arguments. E.g. we create `(tick f) @Bool` instead of `tick (f @Bool)`. + -- | Place ticks exactly on run-time expressions, moving them through pure + -- compile-time constructs such as other ticks, casts or type lambdas. PlaceRuntime - -- | As @PlaceRuntime@, but we float the tick through all - -- lambdas. This makes sense where there is little difference - -- between annotating the lambda and annotating the lambda's code. + -- | As @PlaceRuntime@, but also allow to float the tick through all lambdas. | PlaceNonLam - -- | In addition to floating through lambdas, cost-centre style - -- tickishs can also be moved from constructors, non-function - -- variables and literals. For example: - -- - -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ... - -- - -- Neither the constructor application, the variable or the - -- literal are likely to have any cost worth mentioning. And even - -- if y names a thunk, the call would not care about the - -- evaluation context. Therefore removing all annotations in the - -- above example is safe. + -- | As 'PlaceNonLam', but also float through constructors, non-function + -- variables and literals. | PlaceCostCentre deriving (Eq,Show) @@ -477,7 +521,9 @@ data TickishPlacement = instance Outputable TickishPlacement where ppr = text . show --- | Placement behaviour we want for the ticks +-- | Placement behaviour we want for the ticks. +-- +-- See Note [Tickish placement]. tickishPlace :: GenTickish pass -> TickishPlacement tickishPlace n@ProfNote{} | profNoteCount n = PlaceRuntime @@ -486,6 +532,43 @@ tickishPlace HpcTick{} = PlaceRuntime tickishPlace Breakpoint{} = PlaceRuntime tickishPlace SourceNote{} = PlaceNonLam +-- | Merge two ticks into one, if that is possible. +-- +-- Examples: +-- +-- - combine two source note ticks if one contains the other, +-- - combine a non-counting profiling tick with a non-scoping profiling tick +-- for the same cost centre +-- - combine two equal breakpoint ticks or HPC ticks +combineTickish_maybe :: Eq (GenTickish pass) + => GenTickish pass -> GenTickish pass -> Maybe (GenTickish pass) +combineTickish_maybe + (ProfNote { profNoteCC = cc1, profNoteCount = cnt1, profNoteScope = scope1 }) + (ProfNote { profNoteCC = cc2, profNoteCount = cnt2, profNoteScope = scope2 }) + | cc1 == cc2 + , not cnt1 || not cnt2 + = Just $ ProfNote { profNoteCC = cc1 + , profNoteCount = cnt1 || cnt2 + , profNoteScope = scope1 || scope2 + } +combineTickish_maybe t1@(SourceNote sp1 n1) t2@(SourceNote sp2 n2) + | n1 == n2 + , sp1 `containsSpan` sp2 + = Just t1 + | n1 == n2 + , sp2 `containsSpan` sp1 + = Just t2 + -- NB: it would be possible to use 'combineRealSrcSpans' instead, + -- but that has the risk of combining many source note ticks into a single + -- tick with a huge source span. +combineTickish_maybe t1@(HpcTick {}) t2@(HpcTick {}) + | t1 == t2 + = Just t1 +combineTickish_maybe t1@(Breakpoint {}) t2@(Breakpoint {}) + | t1 == t2 + = Just t1 +combineTickish_maybe _ _ = Nothing + -- | Returns whether one tick "contains" the other one, therefore -- making the second tick redundant. tickishContains :: Eq (GenTickish pass) ===================================== libraries/ghc-heap/tests/tso_and_stack_closures.hs ===================================== @@ -48,7 +48,9 @@ main = do assertEqual (cc_module myCostCentre) "Main" assertEqual (cc_srcloc myCostCentre) (Just "tso_and_stack_closures.hs:24:48-80") assertEqual (cc_is_caf myCostCentre) False - Nothing -> error $ "MyCostCentre not found in:\n" ++ unlines (cc_label <$> linkedCostCentres costCentre) + Nothing -> error "MyCostCentre not found" + -- Don't print all of 'linkedCostCentres costCentre', + -- as that is ~20k lines of output. #endif linkedCostCentres :: Maybe CostCentre -> [CostCentre] ===================================== testsuite/tests/profiling/should_compile/T27121.hs ===================================== @@ -0,0 +1,12 @@ +module T27121 where + +import T27121_aux + +updateFileDiagnostics + :: LanguageContextEnv () + -> IO () +updateFileDiagnostics env = do + withTrace $ \ _tag -> + runLspT env $ do + sendNotification SMethod_TextDocumentPublishDiagnostics + PublishDiagnosticsParams ===================================== testsuite/tests/profiling/should_compile/T27121_aux.hs ===================================== @@ -0,0 +1,354 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} + +module T27121_aux + ( withTrace + , sendNotification + , LspT, runLspT + , SMethod(..) + , LanguageContextEnv + , PublishDiagnosticsParams(..) + ) + where + +-- base +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Data.Kind ( Type ) +import GHC.TypeLits ( Symbol ) + +-------------------------------------------------------------------------------- + +withTrace :: Monad m => ((String -> String -> m ()) -> m a) -> m a +withTrace act + | myUserTracingEnabled + = return undefined + | otherwise = act (\_ _ -> pure ()) +{-# NOINLINE withTrace #-} + +myUserTracingEnabled :: Bool +myUserTracingEnabled = False +{-# NOINLINE myUserTracingEnabled #-} + +type Text = String + +newtype LspT config a = LspT {unLspT :: LanguageContextEnv config -> IO a} + +instance Functor (LspT config) where + fmap f (LspT g) = LspT (fmap f . g) + +instance Applicative (LspT config) where + pure = LspT . const . pure + LspT f <*> LspT a = LspT $ \ env -> f env <*> a env +instance Monad (LspT config) where + LspT a >>= f = LspT $ \ env -> do + b <- a env + unLspT ( f b ) env +instance MonadIO (LspT config) where + liftIO = LspT . const . liftIO + +type role LspT representational nominal + +runLspT :: LanguageContextEnv config -> LspT config a -> IO a +runLspT env (LspT f) = f env +{-# INLINE runLspT #-} + +data PublishDiagnosticsParams = PublishDiagnosticsParams + +data LanguageContextEnv config = + LanguageContextEnv + { resSendMessage :: FromServerMessage -> IO () } + + +sendNotification :: + forall (m :: Method ServerToClient Notification) f config. + MonadLsp config f => + SServerMethod m -> + MessageParams m -> + f () +sendNotification m params = + let msg = TNotificationMessage { _method = m, _params = params } + in case splitServerMethod m of + IsServerNot -> sendToClient $ fromServerNot msg + +type Method :: MessageDirection -> MessageKind -> Type +data Method f t where + Method_TextDocumentImplementation :: Method ClientToServer Request + Method_TextDocumentTypeDefinition :: Method ClientToServer Request + Method_WorkspaceWorkspaceFolders :: Method ServerToClient Request + Method_WorkspaceConfiguration :: Method ServerToClient Request + Method_TextDocumentDocumentColor :: Method ClientToServer Request + Method_TextDocumentColorPresentation :: Method ClientToServer Request + Method_TextDocumentFoldingRange :: Method ClientToServer Request + Method_TextDocumentDeclaration :: Method ClientToServer Request + Method_TextDocumentSelectionRange :: Method ClientToServer Request + Method_WindowWorkDoneProgressCreate :: Method ServerToClient Request + Method_TextDocumentPrepareCallHierarchy :: Method ClientToServer Request + Method_CallHierarchyIncomingCalls :: Method ClientToServer Request + Method_CallHierarchyOutgoingCalls :: Method ClientToServer Request + Method_TextDocumentSemanticTokensFull :: Method ClientToServer Request + Method_TextDocumentSemanticTokensFullDelta :: Method ClientToServer Request + Method_TextDocumentSemanticTokensRange :: Method ClientToServer Request + Method_WorkspaceSemanticTokensRefresh :: Method ServerToClient Request + Method_WindowShowDocument :: Method ServerToClient Request + Method_TextDocumentLinkedEditingRange :: Method ClientToServer Request + Method_WorkspaceWillCreateFiles :: Method ClientToServer Request + Method_WorkspaceWillRenameFiles :: Method ClientToServer Request + Method_WorkspaceWillDeleteFiles :: Method ClientToServer Request + Method_TextDocumentMoniker :: Method ClientToServer Request + Method_TextDocumentPrepareTypeHierarchy :: Method ClientToServer Request + Method_TypeHierarchySupertypes :: Method ClientToServer Request + Method_TypeHierarchySubtypes :: Method ClientToServer Request + Method_TextDocumentInlineValue :: Method ClientToServer Request + Method_WorkspaceInlineValueRefresh :: Method ServerToClient Request + Method_TextDocumentInlayHint :: Method ClientToServer Request + Method_InlayHintResolve :: Method ClientToServer Request + Method_WorkspaceInlayHintRefresh :: Method ServerToClient Request + Method_TextDocumentDiagnostic :: Method ClientToServer Request + Method_WorkspaceDiagnostic :: Method ClientToServer Request + Method_WorkspaceDiagnosticRefresh :: Method ServerToClient Request + Method_ClientRegisterCapability :: Method ServerToClient Request + Method_ClientUnregisterCapability :: Method ServerToClient Request + Method_Initialize :: Method ClientToServer Request + Method_Shutdown :: Method ClientToServer Request + Method_WindowShowMessageRequest :: Method ServerToClient Request + Method_TextDocumentWillSaveWaitUntil :: Method ClientToServer Request + Method_TextDocumentCompletion :: Method ClientToServer Request + Method_CompletionItemResolve :: Method ClientToServer Request + Method_TextDocumentHover :: Method ClientToServer Request + Method_TextDocumentSignatureHelp :: Method ClientToServer Request + Method_TextDocumentDefinition :: Method ClientToServer Request + Method_TextDocumentReferences :: Method ClientToServer Request + Method_TextDocumentDocumentHighlight :: Method ClientToServer Request + Method_TextDocumentDocumentSymbol :: Method ClientToServer Request + Method_TextDocumentCodeAction :: Method ClientToServer Request + Method_CodeActionResolve :: Method ClientToServer Request + Method_WorkspaceSymbol :: Method ClientToServer Request + Method_WorkspaceSymbolResolve :: Method ClientToServer Request + Method_TextDocumentCodeLens :: Method ClientToServer Request + Method_CodeLensResolve :: Method ClientToServer Request + Method_WorkspaceCodeLensRefresh :: Method ServerToClient Request + Method_TextDocumentDocumentLink :: Method ClientToServer Request + Method_DocumentLinkResolve :: Method ClientToServer Request + Method_TextDocumentFormatting :: Method ClientToServer Request + Method_TextDocumentRangeFormatting :: Method ClientToServer Request + Method_TextDocumentOnTypeFormatting :: Method ClientToServer Request + Method_TextDocumentRename :: Method ClientToServer Request + Method_TextDocumentPrepareRename :: Method ClientToServer Request + Method_WorkspaceExecuteCommand :: Method ClientToServer Request + Method_WorkspaceApplyEdit :: Method ServerToClient Request + Method_WorkspaceDidChangeWorkspaceFolders :: Method ClientToServer Notification + Method_WindowWorkDoneProgressCancel :: Method ClientToServer Notification + Method_WorkspaceDidCreateFiles :: Method ClientToServer Notification + Method_WorkspaceDidRenameFiles :: Method ClientToServer Notification + Method_WorkspaceDidDeleteFiles :: Method ClientToServer Notification + Method_NotebookDocumentDidOpen :: Method ClientToServer Notification + Method_NotebookDocumentDidChange :: Method ClientToServer Notification + Method_NotebookDocumentDidSave :: Method ClientToServer Notification + Method_NotebookDocumentDidClose :: Method ClientToServer Notification + Method_Initialized :: Method ClientToServer Notification + Method_Exit :: Method ClientToServer Notification + Method_WorkspaceDidChangeConfiguration :: Method ClientToServer Notification + Method_WindowShowMessage :: Method ServerToClient Notification + Method_WindowLogMessage :: Method ServerToClient Notification + Method_TelemetryEvent :: Method ServerToClient Notification + Method_TextDocumentDidOpen :: Method ClientToServer Notification + Method_TextDocumentDidChange :: Method ClientToServer Notification + Method_TextDocumentDidClose :: Method ClientToServer Notification + Method_TextDocumentDidSave :: Method ClientToServer Notification + Method_TextDocumentWillSave :: Method ClientToServer Notification + Method_WorkspaceDidChangeWatchedFiles :: Method ClientToServer Notification + Method_TextDocumentPublishDiagnostics :: Method ServerToClient Notification + Method_SetTrace :: Method ClientToServer Notification + Method_LogTrace :: Method ServerToClient Notification + Method_CancelRequest :: Method f Notification + Method_Progress :: Method f Notification + Method_CustomMethod :: Symbol -> Method f t + +type SMethod :: forall f t . Method f t -> Type +data SMethod m where + SMethod_TextDocumentImplementation :: SMethod Method_TextDocumentImplementation + SMethod_TextDocumentTypeDefinition :: SMethod Method_TextDocumentTypeDefinition + SMethod_WorkspaceWorkspaceFolders :: SMethod Method_WorkspaceWorkspaceFolders + SMethod_WorkspaceConfiguration :: SMethod Method_WorkspaceConfiguration + SMethod_TextDocumentDocumentColor :: SMethod Method_TextDocumentDocumentColor + SMethod_TextDocumentColorPresentation :: SMethod Method_TextDocumentColorPresentation + SMethod_TextDocumentFoldingRange :: SMethod Method_TextDocumentFoldingRange + SMethod_TextDocumentDeclaration :: SMethod Method_TextDocumentDeclaration + SMethod_TextDocumentSelectionRange :: SMethod Method_TextDocumentSelectionRange + SMethod_WindowWorkDoneProgressCreate :: SMethod Method_WindowWorkDoneProgressCreate + SMethod_TextDocumentPrepareCallHierarchy :: SMethod Method_TextDocumentPrepareCallHierarchy + SMethod_CallHierarchyIncomingCalls :: SMethod Method_CallHierarchyIncomingCalls + SMethod_CallHierarchyOutgoingCalls :: SMethod Method_CallHierarchyOutgoingCalls + SMethod_TextDocumentSemanticTokensFull :: SMethod Method_TextDocumentSemanticTokensFull + SMethod_TextDocumentSemanticTokensFullDelta :: SMethod Method_TextDocumentSemanticTokensFullDelta + SMethod_TextDocumentSemanticTokensRange :: SMethod Method_TextDocumentSemanticTokensRange + SMethod_WorkspaceSemanticTokensRefresh :: SMethod Method_WorkspaceSemanticTokensRefresh + SMethod_WindowShowDocument :: SMethod Method_WindowShowDocument + SMethod_TextDocumentLinkedEditingRange :: SMethod Method_TextDocumentLinkedEditingRange + SMethod_WorkspaceWillCreateFiles :: SMethod Method_WorkspaceWillCreateFiles + SMethod_WorkspaceWillRenameFiles :: SMethod Method_WorkspaceWillRenameFiles + SMethod_WorkspaceWillDeleteFiles :: SMethod Method_WorkspaceWillDeleteFiles + SMethod_TextDocumentMoniker :: SMethod Method_TextDocumentMoniker + SMethod_TextDocumentPrepareTypeHierarchy :: SMethod Method_TextDocumentPrepareTypeHierarchy + SMethod_TypeHierarchySupertypes :: SMethod Method_TypeHierarchySupertypes + SMethod_TypeHierarchySubtypes :: SMethod Method_TypeHierarchySubtypes + SMethod_TextDocumentInlineValue :: SMethod Method_TextDocumentInlineValue + SMethod_WorkspaceInlineValueRefresh :: SMethod Method_WorkspaceInlineValueRefresh + SMethod_TextDocumentInlayHint :: SMethod Method_TextDocumentInlayHint + SMethod_InlayHintResolve :: SMethod Method_InlayHintResolve + SMethod_WorkspaceInlayHintRefresh :: SMethod Method_WorkspaceInlayHintRefresh + SMethod_TextDocumentDiagnostic :: SMethod Method_TextDocumentDiagnostic + SMethod_WorkspaceDiagnostic :: SMethod Method_WorkspaceDiagnostic + SMethod_WorkspaceDiagnosticRefresh :: SMethod Method_WorkspaceDiagnosticRefresh + SMethod_ClientRegisterCapability :: SMethod Method_ClientRegisterCapability + SMethod_ClientUnregisterCapability :: SMethod Method_ClientUnregisterCapability + SMethod_Initialize :: SMethod Method_Initialize + SMethod_Shutdown :: SMethod Method_Shutdown + SMethod_WindowShowMessageRequest :: SMethod Method_WindowShowMessageRequest + SMethod_TextDocumentWillSaveWaitUntil :: SMethod Method_TextDocumentWillSaveWaitUntil + SMethod_TextDocumentCompletion :: SMethod Method_TextDocumentCompletion + SMethod_CompletionItemResolve :: SMethod Method_CompletionItemResolve + SMethod_TextDocumentHover :: SMethod Method_TextDocumentHover + SMethod_TextDocumentSignatureHelp :: SMethod Method_TextDocumentSignatureHelp + SMethod_TextDocumentDefinition :: SMethod Method_TextDocumentDefinition + SMethod_TextDocumentReferences :: SMethod Method_TextDocumentReferences + SMethod_TextDocumentDocumentHighlight :: SMethod Method_TextDocumentDocumentHighlight + SMethod_TextDocumentDocumentSymbol :: SMethod Method_TextDocumentDocumentSymbol + SMethod_TextDocumentCodeAction :: SMethod Method_TextDocumentCodeAction + SMethod_CodeActionResolve :: SMethod Method_CodeActionResolve + SMethod_WorkspaceSymbol :: SMethod Method_WorkspaceSymbol + SMethod_WorkspaceSymbolResolve :: SMethod Method_WorkspaceSymbolResolve + SMethod_TextDocumentCodeLens :: SMethod Method_TextDocumentCodeLens + SMethod_CodeLensResolve :: SMethod Method_CodeLensResolve + SMethod_WorkspaceCodeLensRefresh :: SMethod Method_WorkspaceCodeLensRefresh + SMethod_TextDocumentDocumentLink :: SMethod Method_TextDocumentDocumentLink + SMethod_DocumentLinkResolve :: SMethod Method_DocumentLinkResolve + SMethod_TextDocumentFormatting :: SMethod Method_TextDocumentFormatting + SMethod_TextDocumentRangeFormatting :: SMethod Method_TextDocumentRangeFormatting + SMethod_TextDocumentOnTypeFormatting :: SMethod Method_TextDocumentOnTypeFormatting + SMethod_TextDocumentRename :: SMethod Method_TextDocumentRename + SMethod_TextDocumentPrepareRename :: SMethod Method_TextDocumentPrepareRename + SMethod_WorkspaceExecuteCommand :: SMethod Method_WorkspaceExecuteCommand + SMethod_WorkspaceApplyEdit :: SMethod Method_WorkspaceApplyEdit + SMethod_WorkspaceDidChangeWorkspaceFolders :: SMethod Method_WorkspaceDidChangeWorkspaceFolders + SMethod_WindowWorkDoneProgressCancel :: SMethod Method_WindowWorkDoneProgressCancel + SMethod_WorkspaceDidCreateFiles :: SMethod Method_WorkspaceDidCreateFiles + SMethod_WorkspaceDidRenameFiles :: SMethod Method_WorkspaceDidRenameFiles + SMethod_WorkspaceDidDeleteFiles :: SMethod Method_WorkspaceDidDeleteFiles + SMethod_NotebookDocumentDidOpen :: SMethod Method_NotebookDocumentDidOpen + SMethod_NotebookDocumentDidChange :: SMethod Method_NotebookDocumentDidChange + SMethod_NotebookDocumentDidSave :: SMethod Method_NotebookDocumentDidSave + SMethod_NotebookDocumentDidClose :: SMethod Method_NotebookDocumentDidClose + SMethod_Initialized :: SMethod Method_Initialized + SMethod_Exit :: SMethod Method_Exit + SMethod_WorkspaceDidChangeConfiguration :: SMethod Method_WorkspaceDidChangeConfiguration + SMethod_WindowShowMessage :: SMethod Method_WindowShowMessage + SMethod_WindowLogMessage :: SMethod Method_WindowLogMessage + SMethod_TelemetryEvent :: SMethod Method_TelemetryEvent + SMethod_TextDocumentDidOpen :: SMethod Method_TextDocumentDidOpen + SMethod_TextDocumentDidChange :: SMethod Method_TextDocumentDidChange + SMethod_TextDocumentDidClose :: SMethod Method_TextDocumentDidClose + SMethod_TextDocumentDidSave :: SMethod Method_TextDocumentDidSave + SMethod_TextDocumentWillSave :: SMethod Method_TextDocumentWillSave + SMethod_WorkspaceDidChangeWatchedFiles :: SMethod Method_WorkspaceDidChangeWatchedFiles + SMethod_TextDocumentPublishDiagnostics :: SMethod Method_TextDocumentPublishDiagnostics + SMethod_SetTrace :: SMethod Method_SetTrace + SMethod_LogTrace :: SMethod Method_LogTrace + SMethod_CancelRequest :: SMethod Method_CancelRequest + SMethod_Progress :: SMethod Method_Progress + +type SServerMethod (m :: Method ServerToClient t) = SMethod m + +data MessageDirection = ServerToClient | ClientToServer + +data MessageKind = Notification | Request + + +type ServerNotOrReq :: forall t. Method ServerToClient t -> Type +data ServerNotOrReq m where + IsServerNot :: + ( TMessage m ~ TNotificationMessage m + ) => + ServerNotOrReq (m :: Method ServerToClient Notification) + IsServerReq :: + forall (m :: Method ServerToClient Request). + ( TMessage m ~ TRequestMessage m + ) => + ServerNotOrReq m + +type TMessage :: forall f t. Method f t -> Type +type family TMessage m where + TMessage (Method_CustomMethod s :: Method f t) = () + TMessage (m :: Method f Request) = TRequestMessage m + TMessage (m :: Method f Notification) = TNotificationMessage m + + +data TNotificationMessage (m :: Method f Notification) = TNotificationMessage + { _method :: SMethod m + , _params :: MessageParams m + } + +data TRequestMessage (m :: Method f Request) = TRequestMessage + +type MessageParams :: forall f t . Method f t -> Type +type family MessageParams (m :: Method f t) where + MessageParams Method_TextDocumentPublishDiagnostics = PublishDiagnosticsParams + +class MonadIO m => MonadLsp config m | m -> config where + getLspEnv :: m (LanguageContextEnv config) + +instance MonadLsp config (LspT config) where + {-# INLINE getLspEnv #-} + getLspEnv = LspT pure + + +{-# INLINE splitServerMethod #-} +splitServerMethod :: SServerMethod m -> ServerNotOrReq m +splitServerMethod = \case + SMethod_TextDocumentPublishDiagnostics -> IsServerNot + SMethod_WindowShowMessage -> IsServerNot + SMethod_WindowShowMessageRequest -> IsServerReq + SMethod_WindowShowDocument -> IsServerReq + SMethod_WindowLogMessage -> IsServerNot + SMethod_WindowWorkDoneProgressCreate -> IsServerReq + SMethod_Progress -> IsServerNot + SMethod_TelemetryEvent -> IsServerNot + SMethod_ClientRegisterCapability -> IsServerReq + SMethod_ClientUnregisterCapability -> IsServerReq + SMethod_WorkspaceWorkspaceFolders -> IsServerReq + SMethod_WorkspaceConfiguration -> IsServerReq + SMethod_WorkspaceApplyEdit -> IsServerReq + SMethod_LogTrace -> IsServerNot + SMethod_CancelRequest -> IsServerNot + SMethod_WorkspaceCodeLensRefresh -> IsServerReq + SMethod_WorkspaceSemanticTokensRefresh -> IsServerReq + SMethod_WorkspaceInlineValueRefresh -> IsServerReq + SMethod_WorkspaceInlayHintRefresh -> IsServerReq + SMethod_WorkspaceDiagnosticRefresh -> IsServerReq + +fromServerNot :: + forall (m :: Method ServerToClient Notification). + TMessage m ~ TNotificationMessage m => + TNotificationMessage m -> + FromServerMessage +fromServerNot m@TNotificationMessage{_method = meth} = FromServerMess meth m + + +data FromServerMessage' a where + FromServerMess :: forall t (m :: Method ServerToClient t) a. SMethod m -> TMessage m -> FromServerMessage' a + FromServerRsp :: forall (m :: Method ClientToServer Request) a. a m -> TResponseMessage m -> FromServerMessage' a + +type FromServerMessage = FromServerMessage' SMethod + +data TResponseMessage (m :: Method f Request) = TResponseMessage + +sendToClient :: MonadLsp config m => FromServerMessage -> m () +sendToClient msg = do + f <- resSendMessage <$> getLspEnv + liftIO $ f msg +{-# INLINE sendToClient #-} ===================================== testsuite/tests/profiling/should_compile/all.T ===================================== @@ -21,3 +21,4 @@ test('T15108', [test_opts], compile, ['-O -prof -fprof-auto']) test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894']) test('T20938', [test_opts], compile, ['-O -prof']) test('T26056', [test_opts], compile, ['-O -prof']) +test('T27121', [test_opts, extra_files(['T27121_aux.hs'])], multimod_compile, ['T27121', '-O -prof -fprof-auto']) ===================================== testsuite/tests/simplCore/should_compile/T26941.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +module T26941 where + +import GHC.TypeLits + +import T26941_aux ( SMayNat(SKnown), ListH, shxHead ) + +shsHead :: ListH (Just n : sh) Int -> SNat n +shsHead shx = + case shxHead shx of + SKnown SNat -> SNat ===================================== testsuite/tests/simplCore/should_compile/T26941_aux.hs ===================================== @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module T26941_aux where + +import Data.Kind +import GHC.TypeLits + +shxHead :: ListH (n : sh) i -> SMayNat i n +shxHead list = {-# SCC "bad_scc" #-} + ( case list of (i `ConsKnown` _) -> SKnown i ) + +type ListH :: [Maybe Nat] -> Type -> Type +data ListH sh i where + ConsKnown :: SNat n -> ListH sh i -> ListH (Just n : sh) i + +data SMayNat i n where + SKnown :: SNat n -> SMayNat i (Just n) ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -576,6 +576,8 @@ test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniqu test('T26349', normal, compile, ['-O -ddump-rules']) test('T26681', normal, compile, ['-O']) +test('T26941', [extra_files(['T26941_aux.hs']), req_profiling], multimod_compile, ['T26941', '-v0 -O -prof']) + # T26709: we expect three `case` expressions not four test('T26709', [grep_errmsg(r'case')], multimod_compile, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0a32431b39f2f790975abc1d444625… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0a32431b39f2f790975abc1d444625… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base] More....[skip ci]
by Simon Peyton Jones (＠simonpj) 02 Apr '26

02 Apr '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 809c39ee by Simon Peyton Jones at 2026-04-02T17:37:00+01:00 More....[skip ci] Lots of Names have moved to new mechanism BuiltinRules had KnownKeyNameKeys Start on updating RdrName but incomplete, hence skip ci - - - - - 30 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Name.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/Unique/FM.hs - libraries/base/src/Data/Functor/Classes.hs - libraries/base/src/GHC/KnownKeyNames.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs-boot - libraries/ghc-internal/src/GHC/Internal/CString.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/Unsafe/Coerce.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -222,7 +222,7 @@ basicKnownKeyTable , (mkTcOcc "Eq", eqClassKey) , (mkVarOcc "==", eqClassOpKey) - -- Class Num + -- Numeric operations , (mkTcOcc "Num", numClassKey) , (mkVarOcc "-", minusClassOpKey) , (mkVarOcc "negate", negateClassOpKey) @@ -230,6 +230,8 @@ basicKnownKeyTable , (mkVarOcc "fromRational", fromRationalClassOpKey) , (mkVarOcc "mkRationalBase2", mkRationalBase2IdKey) , (mkVarOcc "mkRationalBase10", mkRationalBase10IdKey) + , (mkVarOcc "divInt#", divIntIdKey) + , (mkVarOcc "modInt#", modIntIdKey) -- Class Functor , (mkTcOcc "Functor", functorClassKey) @@ -286,6 +288,79 @@ basicKnownKeyTable , (mkVarOcc "bindIO", bindIOIdKey) , (mkVarOcc "returnIO", returnIOIdKey) , (mkVarOcc "print", printIdKey) + + -- Known-key names that have BuiltinRules in ConstantFold + , (mkVarOcc "unpackFoldrCString#", unpackCStringFoldrIdKey) + , (mkVarOcc "unpackFoldrCStringUtf8#", unpackCStringFoldrUtf8IdKey) + , (mkVarOcc "unpackAppendCString#", unpackCStringAppendIdKey) + , (mkVarOcc "unpackAppendCStringUtf8#", unpackCStringAppendUtf8IdKey) + , (mkVarOcc "cstringLength#", cstringLengthIdKey) + + , (mkVarOcc "eqString", eqStringIdKey) + , (mkVarOcc "inline", inlineIdKey) + + , (mkVarOcc "unsafeEqualityProof", unsafeEqualityProofIdKey) + , (mkTcOcc "UnsafeEquality", unsafeEqualityTyConKey) + , (mkDataOcc "UnsafeRefl", unsafeReflDataConKey) + + -- Bignum operations, have BuiltinRules in ConstantFold + , (mkVarOcc "bigNatEq#", bignatEqIdKey) + , (mkVarOcc "bigNatCompare", bignatCompareIdKey) + , (mkVarOcc "bigNatCompareWord#", bignatCompareWordIdKey) + , (mkVarOcc "naturalToWord#", naturalToWordIdKey) + , (mkVarOcc "naturalPopCount#", naturalPopCountIdKey) + , (mkVarOcc "naturalShiftR#", naturalShiftRIdKey) + , (mkVarOcc "naturalShiftL#", naturalShiftLIdKey) + , (mkVarOcc "naturalAdd", naturalAddIdKey) + , (mkVarOcc "naturalSub", naturalSubIdKey) + , (mkVarOcc "naturalSubThrow", naturalSubThrowIdKey) + , (mkVarOcc "naturalSubUnsafe", naturalSubUnsafeIdKey) + , (mkVarOcc "naturalMul", naturalMulIdKey) + , (mkVarOcc "naturalQuotRem#", naturalQuotRemIdKey) + , (mkVarOcc "naturalQuot", naturalQuotIdKey) + , (mkVarOcc "naturalRem", naturalRemIdKey) + , (mkVarOcc "naturalAnd", naturalAndIdKey) + , (mkVarOcc "naturalOr", naturalOrIdKey) + , (mkVarOcc "naturalXor", naturalXorIdKey) + , (mkVarOcc "naturalTestBit#", naturalTestBitIdKey) + , (mkVarOcc "naturalBit#", naturalBitIdKey) + , (mkVarOcc "naturalGcd", naturalGcdIdKey) + , (mkVarOcc "naturalLcm", naturalLcmIdKey) + , (mkVarOcc "integerFromNatural", integerFromNaturalIdKey) + , (mkVarOcc "integerToNaturalClamp", integerToNaturalClampIdKey) + , (mkVarOcc "integerToNaturalThrow", integerToNaturalThrowIdKey) + , (mkVarOcc "integerToNatural", integerToNaturalIdKey) + , (mkVarOcc "integerToWord#", integerToWordIdKey) + , (mkVarOcc "integerToInt#", integerToIntIdKey) + , (mkVarOcc "integerToWord64#", integerToWord64IdKey) + , (mkVarOcc "integerToInt64#", integerToInt64IdKey) + , (mkVarOcc "integerFromWord#", integerFromWordIdKey) + , (mkVarOcc "integerFromWord64#", integerFromWord64IdKey) + , (mkVarOcc "integerFromInt64#", integerFromInt64IdKey) + , (mkVarOcc "integerAdd", integerAddIdKey) + , (mkVarOcc "integerMul", integerMulIdKey) + , (mkVarOcc "integerSub", integerSubIdKey) + , (mkVarOcc "integerNegate", integerNegateIdKey) + , (mkVarOcc "integerAbs", integerAbsIdKey) + , (mkVarOcc "integerPopCount#", integerPopCountIdKey) + , (mkVarOcc "integerQuot", integerQuotIdKey) + , (mkVarOcc "integerRem", integerRemIdKey) + , (mkVarOcc "integerDiv", integerDivIdKey) + , (mkVarOcc "integerMod", integerModIdKey) + , (mkVarOcc "integerDivMod#", integerDivModIdKey) + , (mkVarOcc "integerQuotRem#", integerQuotRemIdKey) + , (mkVarOcc "integerEncodeFloat#", integerEncodeFloatIdKey) + , (mkVarOcc "integerEncodeDouble#", integerEncodeDoubleIdKey) + , (mkVarOcc "integerGcd", integerGcdIdKey) + , (mkVarOcc "integerLcm", integerLcmIdKey) + , (mkVarOcc "integerAnd", integerAndIdKey) + , (mkVarOcc "integerOr", integerOrIdKey) + , (mkVarOcc "integerXor", integerXorIdKey) + , (mkVarOcc "integerComplement", integerComplementIdKey) + , (mkVarOcc "integerBit#", integerBitIdKey) + , (mkVarOcc "integerTestBit#", integerTestBitIdKey) + , (mkVarOcc "integerShiftL#", integerShiftLIdKey) + , (mkVarOcc "integerShiftR#", integerShiftRIdKey) ] basicKnownKeyNames :: [Name] -- See Note [Known-key names] @@ -353,9 +428,6 @@ basicKnownKeyNames toIntegerName, toRationalName, fromIntegralName, realToFracName, - -- Int# stuff - divIntName, modIntName, - -- String stuff fromStringName, @@ -370,9 +442,6 @@ basicKnownKeyNames bindMName, thenMName, returnMName, - -- Ix stuff - ixClassName, - -- Read stuff readClassName, @@ -384,9 +453,6 @@ basicKnownKeyNames -- Strings and lists unpackCStringName, unpackCStringUtf8Name, - unpackCStringAppendName, unpackCStringAppendUtf8Name, - unpackCStringFoldrName, unpackCStringFoldrUtf8Name, - cstringLengthName, -- Non-empty lists nonEmptyTyConName, @@ -401,71 +467,12 @@ basicKnownKeyNames jsvalTyConName, -- Others - otherwiseIdName, inlineIdName, - eqStringName, assertName, + otherwiseIdName, + assertName, assertErrorName, traceName, printName, dollarName, - -- ghc-bignum - integerFromNaturalName, - integerToNaturalClampName, - integerToNaturalThrowName, - integerToNaturalName, - integerToWordName, - integerToIntName, - integerToWord64Name, - integerToInt64Name, - integerFromWordName, - integerFromWord64Name, - integerFromInt64Name, - integerAddName, - integerMulName, - integerSubName, - integerNegateName, - integerAbsName, - integerPopCountName, - integerQuotName, - integerRemName, - integerDivName, - integerModName, - integerDivModName, - integerQuotRemName, - integerEncodeFloatName, - integerEncodeDoubleName, - integerGcdName, - integerLcmName, - integerAndName, - integerOrName, - integerXorName, - integerComplementName, - integerBitName, - integerTestBitName, - integerShiftLName, - integerShiftRName, - - naturalToWordName, - naturalPopCountName, - naturalShiftRName, - naturalShiftLName, - naturalAddName, - naturalSubName, - naturalSubThrowName, - naturalSubUnsafeName, - naturalMulName, - naturalQuotRemName, - naturalQuotName, - naturalRemName, - naturalAndName, - naturalOrName, - naturalXorName, - naturalTestBitName, - naturalBitName, - naturalGcdName, - naturalLcmName, - - bignatEqName, - -- Float/Double integerToFloatName, integerToDoubleName, @@ -535,9 +542,6 @@ basicKnownKeyNames , unsatisfiableIdName -- Unsafe coercion proofs - , unsafeEqualityProofName - , unsafeEqualityTyConName - , unsafeReflDataConName , unsafeCoercePrimName , unsafeUnpackJSStringUtf8ShShName @@ -1020,31 +1024,10 @@ metaDataDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaData") metaData metaConsDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaCons") metaConsDataConKey metaSelDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaSel") metaSelDataConKey --- Primitive Int -divIntName, modIntName :: Name -divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey -modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey - -- Base strings Strings -unpackCStringName, unpackCStringFoldrName, - unpackCStringUtf8Name, unpackCStringFoldrUtf8Name, - unpackCStringAppendName, unpackCStringAppendUtf8Name, - eqStringName, cstringLengthName :: Name -cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey -eqStringName = varQual gHC_INTERNAL_BASE (fsLit "eqString") eqStringIdKey - +unpackCStringName, unpackCStringUtf8Name :: Name unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey -unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey -unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey - unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey -unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey -unpackCStringFoldrUtf8Name = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey - - --- The 'inline' function -inlineIdName :: Name -inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey -- Base classes (Eq, Ord, Functor) fmapName, geName, functorClassName :: Name @@ -1108,134 +1091,11 @@ fromStringName = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromSt negateName :: Name negateName = varQual gHC_INTERNAL_NUM (fsLit "negate") negateClassOpKey ---------------------------------- --- ghc-bignum ---------------------------------- -integerFromNaturalName - , integerToNaturalClampName - , integerToNaturalThrowName - , integerToNaturalName - , integerToWordName - , integerToIntName - , integerToWord64Name - , integerToInt64Name - , integerFromWordName - , integerFromWord64Name - , integerFromInt64Name - , integerAddName - , integerMulName - , integerSubName - , integerNegateName - , integerAbsName - , integerPopCountName - , integerQuotName - , integerRemName - , integerDivName - , integerModName - , integerDivModName - , integerQuotRemName - , integerEncodeFloatName - , integerEncodeDoubleName - , integerGcdName - , integerLcmName - , integerAndName - , integerOrName - , integerXorName - , integerComplementName - , integerBitName - , integerTestBitName - , integerShiftLName - , integerShiftRName - , naturalToWordName - , naturalPopCountName - , naturalShiftRName - , naturalShiftLName - , naturalAddName - , naturalSubName - , naturalSubThrowName - , naturalSubUnsafeName - , naturalMulName - , naturalQuotRemName - , naturalQuotName - , naturalRemName - , naturalAndName - , naturalOrName - , naturalXorName - , naturalTestBitName - , naturalBitName - , naturalGcdName - , naturalLcmName - , bignatEqName - , bignatCompareName - , bignatCompareWordName - :: Name - bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name bnbVarQual str key = varQual gHC_INTERNAL_NUM_BIGNAT (fsLit str) key bnnVarQual str key = varQual gHC_INTERNAL_NUM_NATURAL (fsLit str) key bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key --- Types and DataCons -bignatEqName = bnbVarQual "bigNatEq#" bignatEqIdKey -bignatCompareName = bnbVarQual "bigNatCompare" bignatCompareIdKey -bignatCompareWordName = bnbVarQual "bigNatCompareWord#" bignatCompareWordIdKey - -naturalToWordName = bnnVarQual "naturalToWord#" naturalToWordIdKey -naturalPopCountName = bnnVarQual "naturalPopCount#" naturalPopCountIdKey -naturalShiftRName = bnnVarQual "naturalShiftR#" naturalShiftRIdKey -naturalShiftLName = bnnVarQual "naturalShiftL#" naturalShiftLIdKey -naturalAddName = bnnVarQual "naturalAdd" naturalAddIdKey -naturalSubName = bnnVarQual "naturalSub" naturalSubIdKey -naturalSubThrowName = bnnVarQual "naturalSubThrow" naturalSubThrowIdKey -naturalSubUnsafeName = bnnVarQual "naturalSubUnsafe" naturalSubUnsafeIdKey -naturalMulName = bnnVarQual "naturalMul" naturalMulIdKey -naturalQuotRemName = bnnVarQual "naturalQuotRem#" naturalQuotRemIdKey -naturalQuotName = bnnVarQual "naturalQuot" naturalQuotIdKey -naturalRemName = bnnVarQual "naturalRem" naturalRemIdKey -naturalAndName = bnnVarQual "naturalAnd" naturalAndIdKey -naturalOrName = bnnVarQual "naturalOr" naturalOrIdKey -naturalXorName = bnnVarQual "naturalXor" naturalXorIdKey -naturalTestBitName = bnnVarQual "naturalTestBit#" naturalTestBitIdKey -naturalBitName = bnnVarQual "naturalBit#" naturalBitIdKey -naturalGcdName = bnnVarQual "naturalGcd" naturalGcdIdKey -naturalLcmName = bnnVarQual "naturalLcm" naturalLcmIdKey - -integerFromNaturalName = bniVarQual "integerFromNatural" integerFromNaturalIdKey -integerToNaturalClampName = bniVarQual "integerToNaturalClamp" integerToNaturalClampIdKey -integerToNaturalThrowName = bniVarQual "integerToNaturalThrow" integerToNaturalThrowIdKey -integerToNaturalName = bniVarQual "integerToNatural" integerToNaturalIdKey -integerToWordName = bniVarQual "integerToWord#" integerToWordIdKey -integerToIntName = bniVarQual "integerToInt#" integerToIntIdKey -integerToWord64Name = bniVarQual "integerToWord64#" integerToWord64IdKey -integerToInt64Name = bniVarQual "integerToInt64#" integerToInt64IdKey -integerFromWordName = bniVarQual "integerFromWord#" integerFromWordIdKey -integerFromWord64Name = bniVarQual "integerFromWord64#" integerFromWord64IdKey -integerFromInt64Name = bniVarQual "integerFromInt64#" integerFromInt64IdKey -integerAddName = bniVarQual "integerAdd" integerAddIdKey -integerMulName = bniVarQual "integerMul" integerMulIdKey -integerSubName = bniVarQual "integerSub" integerSubIdKey -integerNegateName = bniVarQual "integerNegate" integerNegateIdKey -integerAbsName = bniVarQual "integerAbs" integerAbsIdKey -integerPopCountName = bniVarQual "integerPopCount#" integerPopCountIdKey -integerQuotName = bniVarQual "integerQuot" integerQuotIdKey -integerRemName = bniVarQual "integerRem" integerRemIdKey -integerDivName = bniVarQual "integerDiv" integerDivIdKey -integerModName = bniVarQual "integerMod" integerModIdKey -integerDivModName = bniVarQual "integerDivMod#" integerDivModIdKey -integerQuotRemName = bniVarQual "integerQuotRem#" integerQuotRemIdKey -integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey -integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey -integerGcdName = bniVarQual "integerGcd" integerGcdIdKey -integerLcmName = bniVarQual "integerLcm" integerLcmIdKey -integerAndName = bniVarQual "integerAnd" integerAndIdKey -integerOrName = bniVarQual "integerOr" integerOrIdKey -integerXorName = bniVarQual "integerXor" integerXorIdKey -integerComplementName = bniVarQual "integerComplement" integerComplementIdKey -integerBitName = bniVarQual "integerBit#" integerBitIdKey -integerTestBitName = bniVarQual "integerTestBit#" integerTestBitIdKey -integerShiftLName = bniVarQual "integerShiftL#" integerShiftLIdKey -integerShiftRName = bniVarQual "integerShiftR#" integerShiftRIdKey - --------------------------------- @@ -1262,10 +1122,6 @@ integerToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "integerToDouble#") int rationalToFloatName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToFloat#") rationalToFloatIdKey rationalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToDouble#") rationalToDoubleIdKey --- Class Ix -ixClassName :: Name -ixClassName = clsQual gHC_INTERNAL_IX (fsLit "Ix") ixClassKey - -- Typeable representation types trModuleTyConName , trModuleDataConName @@ -1384,11 +1240,7 @@ unsatisfiableIdName = varQual gHC_INTERNAL_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey -- Unsafe coercion proofs -unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName, - unsafeReflDataConName :: Name -unsafeEqualityProofName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey -unsafeEqualityTyConName = tcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey -unsafeReflDataConName = dcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeRefl") unsafeReflDataConKey +unsafeCoercePrimName:: Name unsafeCoercePrimName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey -- Dynamic ===================================== compiler/GHC/Core.hs ===================================== @@ -88,7 +88,7 @@ module GHC.Core ( RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts, -- ** Operations on 'CoreRule's - ruleArity, ruleName, ruleIdName, ruleActivation, + ruleArity, ruleName, ruleKey, ruleActivation, setRuleIdName, ruleModule, isBuiltinRule, isLocalRule, isAutoRule, ) where @@ -96,19 +96,21 @@ module GHC.Core ( import GHC.Prelude import GHC.Platform -import GHC.Types.Var.Env( InScopeSet ) -import GHC.Types.Var import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Rules.Config ( RuleOpts ) +import GHC.Core.DataCon +import GHC.Unit.Module + import GHC.Types.InlinePragma import GHC.Types.Name import GHC.Types.Name.Set +import GHC.Types.Var.Env( InScopeSet ) +import GHC.Types.Var import GHC.Types.Literal import GHC.Types.Tickish -import GHC.Core.DataCon -import GHC.Unit.Module import GHC.Types.Basic +import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Utils.Binary @@ -1508,14 +1510,17 @@ data CoreRule -- A built-in rule is always visible (there is no such thing as -- an orphan built-in rule.) | BuiltinRule { - ru_name :: RuleName, -- ^ As above - ru_fn :: Name, -- ^ As above + ru_name :: RuleName, -- ^ As above + ru_key :: KnownKeyNameKey, -- ^ Identifies the function + -- Not its Name because BuiltInRules are constants + -- and GHC doesn't know the defining module + -- See Note [Overview of known-key names] ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, -- if it fires, including type arguments ru_try :: RuleFun -- ^ This function does the rewrite. It given too many -- arguments, it simply discards them; the returned 'CoreExpr' - -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args + -- is just the rewrite of function applied to the first 'ru_nargs' args } -- See Note [Extra args in the target] in GHC.Core.Rules @@ -1538,7 +1543,7 @@ isAutoRule :: CoreRule -> Bool isAutoRule (BuiltinRule {}) = False isAutoRule (Rule { ru_auto = is_auto }) = is_auto --- | The number of arguments the 'ru_fn' must be applied +-- | The number of arguments the function must be applied -- to before the rule can match on it ruleArity :: CoreRule -> FullArgCount ruleArity (BuiltinRule {ru_nargs = n}) = n @@ -1555,17 +1560,21 @@ ruleActivation :: CoreRule -> ActivationGhc ruleActivation (BuiltinRule { }) = AlwaysActive ruleActivation (Rule { ru_act = act }) = act --- | The 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side -ruleIdName :: CoreRule -> Name -ruleIdName = ru_fn - isLocalRule :: CoreRule -> Bool isLocalRule (BuiltinRule {}) = False isLocalRule (Rule { ru_local = is_local }) = is_local +-- | The 'Unique' of the function at the head of the rule left hand side +ruleKey :: CoreRule -> Unique +ruleKey (Rule { ru_fn = name }) = nameUnique name +ruleKey (BuiltinRule { ru_key = key }) = key + -- | Set the 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side setRuleIdName :: Name -> CoreRule -> CoreRule -setRuleIdName nm ru = ru { ru_fn = nm } +setRuleIdName nm rule + = case rule of + Rule {} -> rule { ru_fn = nm } + BuiltinRule {} -> rule { ru_key = nameUnique nm } {- ************************************************************************ ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -1810,7 +1810,7 @@ dataConCannotMatch :: [Type] -> DataCon -> Bool dataConCannotMatch tys con -- See (U6) in Note [Implementing unsafeCoerce] -- in base:Unsafe.Coerce - | dataConName con == unsafeReflDataConName + | con `hasKnownKey` unsafeReflDataConKey = False | null inst_theta = False -- Common | all isTyVarTy tys = False -- Also common ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Types.Literal import GHC.Types.Literal.Floating import GHC.Types.Name.Occurrence ( occNameFS ) import GHC.Types.Tickish -import GHC.Types.Name ( Name, nameOccName ) +import GHC.Types.Name ( Name, KnownKeyNameKey, nameUnique, nameOccName ) import GHC.Types.Basic import GHC.Core @@ -870,7 +870,10 @@ primOpRules nm = \case -- useful shorthands mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule -mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) +mkPrimOpRule nm arity rules + = Just $ mkBasicRule (occNameFS (nameOccName nm)) + (nameUnique nm) + arity (msum rules) mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) -> [RuleM CoreExpr] -> Maybe CoreRule @@ -1679,13 +1682,13 @@ but that is only a historical accident. ************************************************************************ -} -mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule +mkBasicRule :: RuleName -> KnownKeyNameKey -> Int -> RuleM CoreExpr -> CoreRule -- Gives the Rule the same name as the primop itself -mkBasicRule op_name n_args rm - = BuiltinRule { ru_name = occNameFS (nameOccName op_name), - ru_fn = op_name, - ru_nargs = n_args, - ru_try = runRuleM rm } +mkBasicRule rule_nm op_key n_args rm + = BuiltinRule { ru_name = rule_nm + , ru_key = op_key + , ru_nargs = n_args + , ru_try = runRuleM rm } newtype RuleM r = RuleM { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r } @@ -2060,6 +2063,30 @@ dataToTagRule = a `mplus` b return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc))) +{- ********************************************************************* +* * + div and mod +* * +********************************************************************* -} + +divIntRule :: RuleM CoreExpr +divIntRule = msum [ nonZeroLit 1 >> binaryLit (intOp2 div) + , leftZero + , do { [arg, Lit (LitNumber LitNumInt d)] <- getArgs + ; Just n <- return $ exactLog2 d + ; platform <- getPlatform + ; return $ Var (primOpId IntSraOp) + `App` arg `App` mkIntVal platform n } ] + +modIntRule :: RuleM CoreExpr +modIntRule = msum [ nonZeroLit 1 >> binaryLit (intOp2 mod) + , leftZero + , do { [arg, Lit (LitNumber LitNumInt d)] <- getArgs + ; Just _ <- return $ exactLog2 d + ; platform <- getPlatform + ; return $ Var (primOpId IntAndOp) + `App` arg `App` mkIntVal platform (d-1) } ] + {- ********************************************************************* * * unsafeEqualityProof @@ -2132,55 +2159,47 @@ is fine. builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [BuiltinRule { ru_name = fsLit "CStringFoldrLit", - ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_cstring_foldr_lit_C }, - BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8", - ru_fn = unpackCStringFoldrUtf8Name, - ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 }, - BuiltinRule { ru_name = fsLit "CStringAppendLit", - ru_fn = unpackCStringAppendName, - ru_nargs = 2, ru_try = match_cstring_append_lit_C }, - BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8", - ru_fn = unpackCStringAppendUtf8Name, - ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 }, - BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = match_eq_string }, - BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName, - ru_nargs = 1, ru_try = match_cstring_length }, - BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, - - mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule, - - mkBasicRule divIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 div) - , leftZero - , do - [arg, Lit (LitNumber LitNumInt d)] <- getArgs - Just n <- return $ exactLog2 d - platform <- getPlatform - return $ Var (primOpId IntSraOp) `App` arg `App` mkIntVal platform n - ], - - mkBasicRule modIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 mod) - , leftZero - , do - [arg, Lit (LitNumber LitNumInt d)] <- getArgs - Just _ <- return $ exactLog2 d - platform <- getPlatform - return $ Var (primOpId IntAndOp) - `App` arg `App` mkIntVal platform (d - 1) - ] - ] + = [ BuiltinRule { ru_name = fsLit "CStringFoldrLit" + , ru_key = unpackCStringFoldrIdKey + , ru_nargs = 4, ru_try = match_cstring_foldr_lit_C } + , BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8" + , ru_key = unpackCStringFoldrUtf8IdKey + ,ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 } + , BuiltinRule { ru_name = fsLit "CStringAppendLit" + , ru_key = unpackCStringAppendIdKey + , ru_nargs = 2, ru_try = match_cstring_append_lit_C } + , BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8" + , ru_key = unpackCStringAppendUtf8IdKey + , ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 } + , BuiltinRule { ru_name = fsLit "CStringLength" + , ru_key = cstringLengthIdKey + , ru_nargs = 1, ru_try = match_cstring_length } + + , BuiltinRule { ru_name = fsLit "EqString" + , ru_key = eqStringIdKey + , ru_nargs = 2, ru_try = match_eq_string } + + , BuiltinRule { ru_name = fsLit "Inline" + , ru_key = inlineIdKey + , ru_nargs = 2, ru_try = \_ _ _ -> match_inline } + + , BuiltinRule { ru_name = fsLit "unsafeEqualityProof" + , ru_key = unsafeEqualityProofIdKey + , ru_nargs = 3, ru_try = runRuleM unsafeEqualityProofRule } + + , BuiltinRule { ru_name = fsLit "divInt#" + , ru_key = divIntIdKey + , ru_nargs = 2, ru_try = runRuleM divIntRule } + , BuiltinRule { ru_name = fsLit "modInt#" + , ru_key = modIntIdKey + , ru_nargs = 2, ru_try = runRuleM modIntRule } + ] ++ builtinBignumRules {-# NOINLINE builtinRules #-} --- there is no benefit to inlining these yet, despite this, GHC produces +-- There is no benefit to inlining these yet, despite this, GHC produces -- unfoldings for this regardless since the floated list entries look small. - {- Note [Built-in bignum rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have some built-in rules for operations on bignum types (Integer, Natural, @@ -2219,54 +2238,54 @@ RuleOpts. builtinBignumRules :: [CoreRule] builtinBignumRules = [ -- conversions - lit_to_integer "Word# -> Integer" integerFromWordName - , lit_to_integer "Int64# -> Integer" integerFromInt64Name - , lit_to_integer "Word64# -> Integer" integerFromWord64Name - , lit_to_integer "Natural -> Integer" integerFromNaturalName + lit_to_integer "Word# -> Integer" integerFromWordIdKey + , lit_to_integer "Int64# -> Integer" integerFromInt64IdKey + , lit_to_integer "Word64# -> Integer" integerFromWord64IdKey + , lit_to_integer "Natural -> Integer" integerFromNaturalIdKey - , integer_to_lit "Integer -> Word# (wrap)" integerToWordName mkWordLitWrap - , integer_to_lit "Integer -> Int# (wrap)" integerToIntName mkIntLitWrap - , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger) - , integer_to_lit "Integer -> Int64# (wrap)" integerToInt64Name (\_ -> mkInt64LitInt64 . fromInteger) - , integer_to_lit "Integer -> Float#" integerToFloatName (\_ -> mkFloatLit . fromInteger) - , integer_to_lit "Integer -> Double#" integerToDoubleName (\_ -> mkDoubleLit . fromInteger) + , integer_to_lit "Integer -> Word# (wrap)" integerToWordIdKey mkWordLitWrap + , integer_to_lit "Integer -> Int# (wrap)" integerToIntIdKey mkIntLitWrap + , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64IdKey (\_ -> mkWord64LitWord64 . fromInteger) + , integer_to_lit "Integer -> Int64# (wrap)" integerToInt64IdKey (\_ -> mkInt64LitInt64 . fromInteger) + , integer_to_lit "Integer -> Float#" integerToFloatIdKey (\_ -> mkFloatLit . fromInteger) + , integer_to_lit "Integer -> Double#" integerToDoubleIdKey (\_ -> mkDoubleLit . fromInteger) - , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampName False True - , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalName False False - , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False + , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampIdKey False True + , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalIdKey False False + , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowIdKey True False - , natural_to_word "Natural -> Word# (wrap)" naturalToWordName + , natural_to_word "Natural -> Word# (wrap)" naturalToWordIdKey -- comparisons (return an unlifted Int#) - , bignum_bin_pred "bigNatEq#" bignatEqName (==) + , bignum_bin_pred "bigNatEq#" bignatEqIdKey (==) -- comparisons (return an Ordering) - , bignum_compare "bignatCompare" bignatCompareName - , bignum_compare "bignatCompareWord#" bignatCompareWordName + , bignum_compare "bignatCompare" bignatCompareIdKey + , bignum_compare "bignatCompareWord#" bignatCompareWordIdKey -- binary operations - , integer_binop "integerAdd" integerAddName (+) - , integer_binop "integerSub" integerSubName (-) - , integer_binop "integerMul" integerMulName (*) - , integer_binop "integerGcd" integerGcdName gcd - , integer_binop "integerLcm" integerLcmName lcm - , integer_binop "integerAnd" integerAndName (.&.) - , integer_binop "integerOr" integerOrName (.|.) - , integer_binop "integerXor" integerXorName xor - - , natural_binop "naturalAdd" naturalAddName (+) - , natural_binop "naturalMul" naturalMulName (*) - , natural_binop "naturalGcd" naturalGcdName gcd - , natural_binop "naturalLcm" naturalLcmName lcm - , natural_binop "naturalAnd" naturalAndName (.&.) - , natural_binop "naturalOr" naturalOrName (.|.) - , natural_binop "naturalXor" naturalXorName xor + , integer_binop "integerAdd" integerAddIdKey (+) + , integer_binop "integerSub" integerSubIdKey (-) + , integer_binop "integerMul" integerMulIdKey (*) + , integer_binop "integerGcd" integerGcdIdKey gcd + , integer_binop "integerLcm" integerLcmIdKey lcm + , integer_binop "integerAnd" integerAndIdKey (.&.) + , integer_binop "integerOr" integerOrIdKey (.|.) + , integer_binop "integerXor" integerXorIdKey xor + + , natural_binop "naturalAdd" naturalAddIdKey (+) + , natural_binop "naturalMul" naturalMulIdKey (*) + , natural_binop "naturalGcd" naturalGcdIdKey gcd + , natural_binop "naturalLcm" naturalLcmIdKey lcm + , natural_binop "naturalAnd" naturalAndIdKey (.&.) + , natural_binop "naturalOr" naturalOrIdKey (.|.) + , natural_binop "naturalXor" naturalXorIdKey xor -- Natural subtraction: it's a binop but it can fail because of underflow so -- we have several primitives to handle here. - , natural_sub "naturalSubUnsafe" naturalSubUnsafeName - , natural_sub "naturalSubThrow" naturalSubThrowName - , mkRule "naturalSub" naturalSubName 2 $ do + , natural_sub "naturalSubUnsafe" naturalSubUnsafeIdKey + , natural_sub "naturalSubThrow" naturalSubThrowIdKey + , mkRule "naturalSub" naturalSubIdKey 2 $ do [a0,a1] <- getArgs x <- isNaturalLiteral a0 y <- isNaturalLiteral a1 @@ -2278,53 +2297,53 @@ builtinBignumRules = else ret 2 $ mkNaturalExpr platform (x - y) -- unary operations - , bignum_unop "integerNegate" integerNegateName mkIntegerExpr negate - , bignum_unop "integerAbs" integerAbsName mkIntegerExpr abs - , bignum_unop "integerComplement" integerComplementName mkIntegerExpr complement + , bignum_unop "integerNegate" integerNegateIdKey mkIntegerExpr negate + , bignum_unop "integerAbs" integerAbsIdKey mkIntegerExpr abs + , bignum_unop "integerComplement" integerComplementIdKey mkIntegerExpr complement - , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap - , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap + , bignum_popcount "integerPopCount" integerPopCountIdKey mkLitIntWrap + , bignum_popcount "naturalPopCount" naturalPopCountIdKey mkLitWordWrap -- Bits.bit - , bignum_bit "integerBit" integerBitName mkIntegerExpr - , bignum_bit "naturalBit" naturalBitName mkNaturalExpr + , bignum_bit "integerBit" integerBitIdKey mkIntegerExpr + , bignum_bit "naturalBit" naturalBitIdKey mkNaturalExpr -- Bits.testBit - , bignum_testbit "integerTestBit" integerTestBitName - , bignum_testbit "naturalTestBit" naturalTestBitName + , bignum_testbit "integerTestBit" integerTestBitIdKey + , bignum_testbit "naturalTestBit" naturalTestBitIdKey -- Bits.shift - , bignum_shift "integerShiftL" integerShiftLName shiftL mkIntegerExpr - , bignum_shift "integerShiftR" integerShiftRName shiftR mkIntegerExpr - , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkNaturalExpr - , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkNaturalExpr + , bignum_shift "integerShiftL" integerShiftLIdKey shiftL mkIntegerExpr + , bignum_shift "integerShiftR" integerShiftRIdKey shiftR mkIntegerExpr + , bignum_shift "naturalShiftL" naturalShiftLIdKey shiftL mkNaturalExpr + , bignum_shift "naturalShiftR" naturalShiftRIdKey shiftR mkNaturalExpr -- division - , divop_one "integerQuot" integerQuotName quot mkIntegerExpr - , divop_one "integerRem" integerRemName rem mkIntegerExpr - , divop_one "integerDiv" integerDivName div mkIntegerExpr - , divop_one "integerMod" integerModName mod mkIntegerExpr - , divop_both "integerDivMod" integerDivModName divMod mkIntegerExpr - , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr + , divop_one "integerQuot" integerQuotIdKey quot mkIntegerExpr + , divop_one "integerRem" integerRemIdKey rem mkIntegerExpr + , divop_one "integerDiv" integerDivIdKey div mkIntegerExpr + , divop_one "integerMod" integerModIdKey mod mkIntegerExpr + , divop_both "integerDivMod" integerDivModIdKey divMod mkIntegerExpr + , divop_both "integerQuotRem" integerQuotRemIdKey quotRem mkIntegerExpr - , divop_one "naturalQuot" naturalQuotName quot mkNaturalExpr - , divop_one "naturalRem" naturalRemName rem mkNaturalExpr - , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr + , divop_one "naturalQuot" naturalQuotIdKey quot mkNaturalExpr + , divop_one "naturalRem" naturalRemIdKey rem mkNaturalExpr + , divop_both "naturalQuotRem" naturalQuotRemIdKey quotRem mkNaturalExpr -- conversions from Rational for Float/Double literals - , rational_to "rationalToFloat#" rationalToFloatName LitFloat - , rational_to "rationalToDouble#" rationalToDoubleName LitDouble + , rational_to "rationalToFloat#" rationalToFloatIdKey LitFloat + , rational_to "rationalToDouble#" rationalToDoubleIdKey LitDouble -- conversions from Integer for Float/Double literals - , integer_encode_float "integerEncodeFloat" integerEncodeFloatName + , integer_encode_float "integerEncodeFloat" integerEncodeFloatIdKey encodeLitFloat LitFloat - , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName + , integer_encode_float "integerEncodeDouble" integerEncodeDoubleIdKey encodeLitDouble LitDouble ] where - mkRule str name nargs f = BuiltinRule + mkRule str key nargs f = BuiltinRule { ru_name = fsLit str - , ru_fn = name + , ru_key = key , ru_nargs = nargs , ru_try = runRuleM $ do env <- getRuleOpts @@ -2470,7 +2489,8 @@ builtinBignumRules = platform <- getPlatform pure $ mkCoreUnboxedTuple [mk_lit platform r, mk_lit platform s] - integer_encode_float :: String -> Name -> (Integer -> Int -> LitFloating) -> LitFloatingType -> CoreRule + integer_encode_float :: String -> KnownKeyNameKey + -> (Integer -> Int -> LitFloating) -> LitFloatingType -> CoreRule integer_encode_float str name encode_fun destType = mkRule str name 2 $ do [a0,a1] <- getArgs x <- isIntegerLiteral a0 @@ -2479,7 +2499,7 @@ builtinBignumRules = yInt <- liftMaybe (toIntegralSized y :: Maybe Int) pure $ Lit $ LitFloating destType $ encode_fun x yInt - rational_to :: String -> Name -> LitFloatingType -> CoreRule + rational_to :: String -> KnownKeyNameKey -> LitFloatingType -> CoreRule rational_to str name destType = mkRule str name 2 $ do -- This turns `rationalToFloat# n d` where `n` and `d` are literals into -- a literal Float# (and similarly for Double#). ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -27,25 +27,27 @@ module GHC.Core.Ppr ( import GHC.Prelude import GHC.Core +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr +import GHC.Core.Coercion import GHC.Core.Stats (exprStats) + import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Literal( pprLiteral ) -import GHC.Types.Name( pprInfixName, pprPrefixName ) +import GHC.Types.Name( pprInfixName, pprPrefixName, pprKnownKey ) import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.InlinePragma import GHC.Types.Demand import GHC.Types.Cpr -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.TyCo.Ppr -import GHC.Core.Coercion +import GHC.Types.SrcLoc ( pprUserRealSpan ) +import GHC.Types.Tickish import GHC.Types.Basic + import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Types.SrcLoc ( pprUserRealSpan ) -import GHC.Types.Tickish {- ************************************************************************ @@ -668,8 +670,8 @@ pprRules :: [CoreRule] -> SDoc pprRules rules = vcat (map pprRule rules) pprRule :: CoreRule -> SDoc -pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) - = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name) +pprRule (BuiltinRule { ru_key = key, ru_name = name}) + = text "Built in rule for" <+> pprKnownKey key <> colon <+> doubleQuotes (ftext name) pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args, ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -79,8 +79,8 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) import GHC.Types.Name.Set -import GHC.Types.Name.Env import GHC.Types.Name.Occurrence( occNameFS ) +import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Tickish import GHC.Types.Basic @@ -357,7 +357,7 @@ addIdSpecialisations id rules addRulesToId :: RuleBase -> Id -> Id -- Add rules in the RuleBase to the rules in the Id addRulesToId rule_base bndr - | Just rules <- lookupNameEnv rule_base (idName bndr) + | Just rules <- lookupRuleBase rule_base (idUnique bndr) = bndr `addIdSpecialisations` rules | otherwise = bndr @@ -376,12 +376,12 @@ rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds -} -- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules -type RuleBase = NameEnv [CoreRule] +type RuleBase = UniqFM Unique [CoreRule] -- The rules are unordered; -- we sort out any overlaps on lookup emptyRuleBase :: RuleBase -emptyRuleBase = emptyNameEnv +emptyRuleBase = emptyUFM mkRuleBase :: [CoreRule] -> RuleBase mkRuleBase rules = extendRuleBaseList emptyRuleBase rules @@ -392,7 +392,10 @@ extendRuleBaseList rule_base new_guys extendRuleBase :: RuleBase -> CoreRule -> RuleBase extendRuleBase rule_base rule - = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule + = addToUFM_Acc (:) Utils.singleton rule_base (ruleKey rule) rule + +lookupRuleBase :: RuleBase -> Unique -> Maybe [CoreRule] +lookupRuleBase = lookupUFM pprRuleBase :: RuleBase -> SDoc pprRuleBase rules = pprUFM rules $ \rss -> @@ -440,9 +443,9 @@ addLocalRules rule_env rules = rule_env { re_local_rules = extendRuleBaseList (re_local_rules rule_env) rules } emptyRuleEnv :: RuleEnv -emptyRuleEnv = RuleEnv { re_local_rules = emptyNameEnv - , re_home_rules = emptyNameEnv - , re_eps_rules = emptyNameEnv +emptyRuleEnv = RuleEnv { re_local_rules = emptyRuleBase + , re_home_rules = emptyRuleBase + , re_eps_rules = emptyRuleBase , re_visible_orphs = emptyModuleSet } getRules :: RuleEnv -> Id -> [CoreRule] @@ -478,10 +481,10 @@ getRules (RuleEnv { re_local_rules = local_rule_base drop_orphs eps_rules ++ idCoreRules fn where - fn_name = idName fn + fn_key = idUnique fn drop_orphs [] = [] -- Fast path; avoid invoking recursive filter drop_orphs xs = filter (ruleIsVisible orphs) xs - get rb = lookupNameEnv rb fn_name `orElse` [] + get rb = lookupRuleBase rb fn_key `orElse` [] ruleIsVisible :: ModuleSet -> CoreRule -> Bool ruleIsVisible _ BuiltinRule{} = True ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -715,8 +715,8 @@ magicDefnModules = mkModuleSet $ map (nameModule . getName . fst) magicDefns mkUnsafeCoercePrimPair :: Id -> CoreExpr -> DsM (Id, CoreExpr) -- See Note [Wiring in unsafeCoerce#] for the defn we are creating here mkUnsafeCoercePrimPair _old_id old_expr - = do { unsafe_equality_proof_id <- dsLookupGlobalId unsafeEqualityProofName - ; unsafe_equality_tc <- dsLookupTyCon unsafeEqualityTyConName + = do { unsafe_equality_proof_id <- dsLookupKnownKeyId unsafeEqualityProofIdKey + ; unsafe_equality_tc <- dsLookupKnownKeyTyCon unsafeEqualityTyConKey ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc ===================================== compiler/GHC/HsToCore/Match/Literal.hs ===================================== @@ -609,7 +609,7 @@ matchLiterals (var :| vars) ty sub_groups -- we can use a case expression; for String we need -- a chain of if-then-else ; if isStringTy (idType var) then - do { eq_str <- dsLookupGlobalId eqStringName + do { eq_str <- dsLookupKnownKeyId eqStringIdKey ; mrs <- mapM (wrap_str_guard eq_str) alts ; return (foldr1 combineMatchResults mrs) } else ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -213,13 +213,29 @@ produced don't get through the typechecker. gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon , dit_rep_tc_args = tycon_args }) = do - do { eq_RDR <- rnLookupKnownKeyRdr eqClassOpKey - ; return ([mk_eq_bind eq_RDR], emptyBag) } + do { eq_RDR <- tcLookupKnownKey_RDR eqClassOpKey + ; ([mk_eq_bind eq_RDR], emptyBag) } where all_cons = getPossibleDataCons tycon tycon_args non_nullary_cons = filter (not . isNullarySrcDataCon) all_cons - ------------------------------------------------------------------ + -- Generate tag check. See #17240 + eq_expr_with_tag_check = nlHsCase + (nlHsPar (untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (nlHsOpApp (nlHsVar ah_RDR) neInt_RDR (nlHsVar bh_RDR)))) + [ mkHsCaseAlt (nlLitPat (HsIntPrim NoSourceText 1)) false_Expr + , mkHsCaseAlt nlWildPat ( + nlHsCase + (nlHsVar a_RDR) + -- Only one branch to match all nullary constructors + -- as we already know the tags match but do not emit + -- the branch if there are no nullary constructors + (let non_nullary_pats = map pats_etc non_nullary_cons + in if null non_nullary_cons + then non_nullary_pats + else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr])) + ] + mk_eq_bind eq_RDR = mkFunBindEC 2 loc eq_RDR (const true_Expr) binds where binds @@ -239,45 +255,29 @@ gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon | otherwise = [([a_Pat, b_Pat], eq_expr_with_tag_check)] - -- Generate tag check. See #17240 - eq_expr_with_tag_check = nlHsCase - (nlHsPar (untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (nlHsOpApp (nlHsVar ah_RDR) neInt_RDR (nlHsVar bh_RDR)))) - [ mkHsCaseAlt (nlLitPat (HsIntPrim NoSourceText 1)) false_Expr - , mkHsCaseAlt nlWildPat ( - nlHsCase - (nlHsVar a_RDR) - -- Only one branch to match all nullary constructors - -- as we already know the tags match but do not emit - -- the branch if there are no nullary constructors - (let non_nullary_pats = map pats_etc non_nullary_cons - in if null non_nullary_cons - then non_nullary_pats - else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr])) - ] - - nested_eq_expr [] [] [] = true_Expr - nested_eq_expr tys as bs - = foldr1 and_Expr $ expectNonEmpty $ zipWith3Equal nested_eq tys as bs - -- Using 'foldr1' here ensures that the derived code is correctly - -- associated. See #10859. - where - nested_eq ty a b = nlHsPar (eq_Expr eq_RDR ty (nlHsVar a) (nlHsVar b)) + ------------------------------------------------------------------ + nested_eq_expr [] [] [] = true_Expr + nested_eq_expr tys as bs + = foldr1 and_Expr $ expectNonEmpty $ zipWith3Equal nested_eq tys as bs + -- Using 'foldr1' here ensures that the derived code is correctly + -- associated. See #10859. + where + nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) - gen_con_fields_and_tys data_con - | tys_needed <- derivDataConInstArgTys data_con dit - , con_arity <- length tys_needed - , as_needed <- take con_arity as_RDRs - , bs_needed <- take con_arity bs_RDRs - = (as_needed, bs_needed, tys_needed) + gen_con_fields_and_tys data_con + | tys_needed <- derivDataConInstArgTys data_con dit + , con_arity <- length tys_needed + , as_needed <- take con_arity as_RDRs + , bs_needed <- take con_arity bs_RDRs + = (as_needed, bs_needed, tys_needed) - pats_etc data_con - | (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con - , data_con_RDR <- getRdrName data_con - , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed - , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed - , fields_eq_expr <- nested_eq_expr tys_needed as_needed bs_needed - = mkHsCaseAlt con1_pat (nlHsCase (nlHsVar b_RDR) [mkHsCaseAlt con2_pat fields_eq_expr]) + pats_etc data_con + | (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con + , data_con_RDR <- getRdrName data_con + , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed + , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed + , fields_eq_expr <- nested_eq_expr tys_needed as_needed bs_needed + = mkHsCaseAlt con1_pat (nlHsCase (nlHsVar b_RDR) [mkHsCaseAlt con2_pat fields_eq_expr]) {- ************************************************************************ @@ -650,17 +650,16 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do -- See Note [Auxiliary binders] tag2con_RDR <- new_tag2con_rdr_name loc tycon maxtag_RDR <- new_maxtag_rdr_name loc tycon - eq_RDR <- rnLookupKnownKeyRdr eqClassOpKey - return ( method_binds eq_RDR tag2con_RDR maxtag_RDR + return ( method_binds tag2con_RDR maxtag_RDR , aux_binds tag2con_RDR maxtag_RDR ) where - method_binds eq_RDR tag2con_RDR maxtag_RDR = - [ succ_enum eq_RDR tag2con_RDR maxtag_RDR - , pred_enum eq_RDR tag2con_RDR - , to_enum tag2con_RDR maxtag_RDR - , enum_from tag2con_RDR maxtag_RDR -- [0 ..] - , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..] + method_binds tag2con_RDR maxtag_RDR = + [ succ_enum tag2con_RDR maxtag_RDR + , pred_enum tag2con_RDR + , to_enum tag2con_RDR maxtag_RDR + , enum_from tag2con_RDR maxtag_RDR -- [0 ..] + , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..] , from_enum ] aux_binds tag2con_RDR maxtag_RDR = listToBag @@ -670,7 +669,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do occ_nm = getOccString tycon - succ_enum eq_RDR tag2con_RDR maxtag_RDR + succ_enum tag2con_RDR maxtag_RDR = mkSimpleGeneratedFunBind loc succ_RDR (noLocA [a_Pat]) $ untag_Expr [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR, @@ -680,7 +679,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], nlHsIntLit 1])) - pred_enum eq_RDR tag2con_RDR + pred_enum tag2con_RDR = mkSimpleGeneratedFunBind loc pred_RDR (noLocA [a_Pat]) $ untag_Expr [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, @@ -2487,8 +2486,8 @@ and_Expr a b = genOpApp a and_RDR b ----------------------------------------------------------------------- -eq_Expr :: RdrName -> Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -eq_Expr eq_RDR ty a b +eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +eq_Expr ty a b | not (isUnliftedType ty) = genOpApp a eq_RDR b | otherwise = genPrimOpApp a prim_eq b where ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -515,7 +515,7 @@ mkDictSelId name clas -- op (dfT d1 d2) ---> opT d1 d2 rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` occNameFS (getOccName name) - , ru_fn = name + , ru_key = nameUnique name , ru_nargs = n_ty_args + 1 , ru_try = dictSelRule val_index n_ty_args } ===================================== compiler/GHC/Types/Name.hs ===================================== @@ -127,6 +127,9 @@ A "known-key" name is one * but that's all that GHC knows about it In particular, GHC does /not/ know in which module the entity is defined. +See Note [Recipe for adding a known-key name] for +how to add a known-key name to GHC. + Example: the `Eq` class has OccName "Eq" and unique `eqClassKey`. It happens to be defined in ghc-internal:GHC.Internal.Classes, but GHC does not know that. @@ -245,6 +248,32 @@ Wrinkles (KKN1) We need some special treatment of unused-import warnings. See (UI1) in Note [Unused imports] in GHC.Rename.Names +Note [Recipe for adding a known-key name] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To make `wombat` into a known-key name, you must ensure that: + +* The module M that defines `wombat` is compiled with `-fdefines-known-key-names`. + +* If M.hs has an `M.hs-boot` file, it too must be compiled + with `-fdefines-known-key-names`. + +* The module `GHC.KnownKeyNames` must export `wombat`. + +* The big list `GHC.Builtin.Names.knownKeyTable` must contain an + entry for `wombat`. + +* In any module in `base` or `ghc-internal` (which are compiled with + -frebindable-known-key-names), you must ensure that `wombat` is in scope + by saying `import M( wombat )`. + + If you just say `import M` you may get a "unused import" warning; that + warning is suppressed for known-key names if you import `wombat` by name. + + You do not need to import the module in which `wombat` is /defined/, although + you may. It is enough simply to bring `wombat` in scope by importing a + module that re-exports. You can even import `GHC.KnownKeyNames`, if that does + not create a module loop! + Note [About the NameSorts] ~~~~~~~~~~~~~~~~~~~~~~~~~~ 1. Initially: ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -196,7 +196,7 @@ data RdrName -- we want to say \"Use Prelude.map dammit\". One of these -- can be created with 'mkOrig' - | Exact Name + | Exact ExactSpec -- ^ Exact name -- -- We know exactly the 'Name'. This is used: @@ -209,6 +209,11 @@ data RdrName -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' deriving Data +data ExactSpec + = ExactName Name -- Use this when you know the exact Name + | ExactKey KnownKeyNameKey -- Use this for known-key names + deriving Data + {- ************************************************************************ * * @@ -287,7 +292,7 @@ getRdrName :: NamedThing thing => thing -> RdrName getRdrName name = nameRdrName (getName name) nameRdrName :: Name -> RdrName -nameRdrName name = Exact name +nameRdrName name = Exact (ExactName name) -- Keep the Name even for Internal names, so that the -- unique is still there for debug printing, particularly -- of Types (which are converted to IfaceTypes before printing) ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -176,6 +176,8 @@ addToUFM_C -> UniqFM key elt -- ^ old -> key -> elt -- ^ new -> UniqFM key elt -- ^ result +{-# SPECIALISE addToUFM_C :: (elt -> elt -> elt) -> UniqFM Unique elt + -> Unique -> elt -> UniqFM Unique elt #-} -- Arguments of combining function of M.insertWith and addToUFM_C are flipped. addToUFM_C f (UFM m) k v = UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) @@ -197,6 +199,8 @@ addToUFM_Acc -> UniqFM key elts -- old -> key -> elt -- new -> UniqFM key elts -- result +{-# SPECIALISE addToUFM_Acc :: (elt -> elts -> elts) -> (elt->elts) -> UniqFM Unique elts + -> Unique -> elt -> UniqFM Unique elts #-} addToUFM_Acc exi new (UFM m) k v = UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) ===================================== libraries/base/src/Data/Functor/Classes.hs ===================================== @@ -71,6 +71,8 @@ module Data.Functor.Classes ( showsBinary1, ) where +import GHC.KnownKeyNames + import Control.Applicative (Alternative((<|>)), Const(Const)) import GHC.Internal.Data.Functor.Identity (Identity(Identity)) @@ -90,6 +92,7 @@ import GHC.Internal.Text.Read.Lex (Lexeme(..)) import GHC.Internal.Text.Show (showListWith) import Prelude + -- $setup -- >>> import Prelude -- >>> import Data.Complex (Complex (..)) ===================================== libraries/base/src/GHC/KnownKeyNames.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Trustworthy, RankNTypes #-} +{-# LANGUAGE MagicHash, Trustworthy, RankNTypes #-} {-# OPTIONS_GHC -fdefines-known-key-names #-} -- See Note [Known-key names and IsList] @@ -32,6 +32,7 @@ module GHC.KnownKeyNames , Num, Integral, Real , (-), negate, fromInteger, fromRational , mkRationalBase2, mkRationalBase10 + , divInt#, modInt# -- Strings , IsString @@ -47,12 +48,37 @@ module GHC.KnownKeyNames -- IO , thenIO, bindIO, returnIO, print + + -- Names that have BuiltinRules + , CS.unpackFoldrCString#, CS.unpackFoldrCStringUtf8#, CS.unpackAppendCString# + , CS.unpackAppendCStringUtf8#, CS.cstringLength# + , eqString, inline + + , UnsafeEquality( UnsafeRefl ), unsafeEqualityProof + + -- Bignums + , bigNatEq#, bigNatCompare, bigNatCompareWord# + , naturalToWord#, naturalPopCount#, naturalShiftR#, naturalShiftL# + , naturalAdd, naturalSub, naturalSubThrow, naturalSubUnsafe + , naturalMul, naturalQuotRem#, naturalQuot, naturalRem, naturalAnd + , naturalOr, naturalXor, naturalTestBit#, naturalBit#, naturalGcd, naturalLcm + + , integerFromNatural, integerToNaturalClamp, integerToNaturalThrow, integerToNatural + , integerToWord#, integerToInt#, integerToWord64#, integerToInt64#, integerFromWord# + , integerFromWord64#, integerFromInt64#, integerAdd, integerMul, integerSub + , integerNegate, integerAbs, integerPopCount#, integerQuot, integerRem, integerDiv + , integerMod, integerDivMod#, integerQuotRem#, integerEncodeFloat#, integerEncodeDouble# + , integerGcd, integerLcm, integerAnd, integerOr, integerXor + , integerComplement, integerBit#, integerTestBit#, integerShiftL#, integerShiftR# ) where import Prelude import Data.String( IsString ) -import GHC.Internal.Base( Alternative, join, thenIO, bindIO, returnIO ) +import GHC.Internal.Base( Alternative, join, thenIO, bindIO, returnIO + , eqString ) +import GHC.Internal.Classes( divInt#, modInt# ) import GHC.Internal.Ix( Ix ) +import GHC.Internal.Magic( inline ) import GHC.Internal.Data.Data( Data ) import GHC.Internal.Data.String( fromString ) import GHC.Internal.Real( mkRationalBase2, mkRationalBase10 ) @@ -62,12 +88,20 @@ import GHC.Internal.Control.Monad.Zip( mzip ) import GHC.Internal.Control.Arrow( arr, (>>>), first, app, (|||) ) import GHC.Internal.OverloadedLabels( fromLabel ) import GHC.Internal.Records( HasField, getField ) +import GHC.Internal.CString as CS import qualified GHC.Internal.IsList as IL +import GHC.Internal.Unsafe.Coerce( UnsafeEquality(..), unsafeEqualityProof ) + +import GHC.Internal.Bignum.Integer +import GHC.Internal.Bignum.Natural +import GHC.Internal.Bignum.BigNat + {- Note [Known-key names and IsList] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Very annoyingly both the classes Foldable and IsList have a method `toList`. we can't have two known-key names with the same OccName. + -} isList_toList :: IL.IsList l => l -> [IL.Item l] ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs ===================================== @@ -9,6 +9,10 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE BinaryLiterals #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + {-# OPTIONS_GHC -Wno-name-shadowing #-} -- | Multi-precision natural ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs-boot ===================================== @@ -2,6 +2,9 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + module GHC.Internal.Bignum.BigNat where import GHC.Internal.Bignum.WordArray ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs ===================================== @@ -8,6 +8,9 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + -- | -- Module : GHC.Internal.Bignum.Integer -- Copyright : (c) Sylvain Henry 2019, ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs-boot ===================================== @@ -2,6 +2,9 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + module GHC.Internal.Bignum.Integer where import GHC.Internal.Types ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs ===================================== @@ -5,6 +5,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + #include "MachDeps.h" #include "WordSize.h" ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs-boot ===================================== @@ -1,6 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + module GHC.Internal.Bignum.Natural where import {-# SOURCE #-} GHC.Internal.Bignum.BigNat ===================================== libraries/ghc-internal/src/GHC/Internal/CString.hs ===================================== @@ -1,4 +1,8 @@ {-# LANGUAGE MagicHash, NoImplicitPrelude, BangPatterns, UnliftedFFITypes #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines unpackFoldrCString# etc + ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.CString ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs ===================================== @@ -25,9 +25,7 @@ import GHC.Internal.Data.Foldable (Foldable(foldMap)) import GHC.Internal.Foreign.Storable (Storable) import GHC.Internal.Ix (Ix) -import GHC.Internal.Base ( - Applicative(..), Functor(..), Monoid(..), Semigroup(..), ($), (.), - ) +import GHC.Internal.Base import GHC.Internal.Classes (Eq(..), Ord(..)) import GHC.Internal.Enum (Bounded, Enum) import GHC.Internal.Float (Floating, RealFloat) @@ -36,6 +34,7 @@ import GHC.Internal.Prim (coerce) import GHC.Internal.Real (Fractional, Integral, Real, RealFrac) import GHC.Internal.Read (Read(readsPrec), readParen, lex) import GHC.Internal.Show (Show(showsPrec), showParen, showString) + import GHC.Internal.Num( fromInteger ) -- For known-key names -- | The 'Const' functor. ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs ===================================== @@ -34,12 +34,11 @@ module GHC.Internal.Data.Functor.Identity ( import GHC.Internal.Data.Bits (Bits, FiniteBits) import GHC.Internal.Data.Coerce -import GHC.Internal.Data.Foldable +import GHC.Internal.Data.Foldable as Foldable import GHC.Internal.Data.Functor.Utils ((#.)) import GHC.Internal.Foreign.Storable (Storable) import GHC.Internal.Ix (Ix) -import GHC.Internal.Base ( Applicative(..), Functor(..), Monad(..) - , Semigroup, Monoid, ($), (.) ) +import GHC.Internal.Base import GHC.Internal.Classes (Eq(..), Ord(..)) import GHC.Internal.Enum (Bounded, Enum) import GHC.Internal.Float (Floating, RealFloat) @@ -117,7 +116,7 @@ instance Foldable Identity where foldl' = coerce foldl1 _ = runIdentity foldr f z (Identity x) = f x z - foldr' = foldr + foldr' = Foldable.foldr -- Not the one from GHC.Internal.Base! foldr1 _ = runIdentity length _ = 1 maximum = runIdentity ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs ===================================== @@ -28,10 +28,7 @@ import GHC.Internal.Classes (Eq(..), Ord(..)) import GHC.Internal.Data.Bits (Bits, FiniteBits, complement) import GHC.Internal.Foreign.Storable (Storable) import GHC.Internal.Ix (Ix) -import GHC.Internal.Base ( - Applicative(..), Functor(..), Monad(..), Monoid, Semigroup, otherwise, - ($), (.), - ) +import GHC.Internal.Base import GHC.Internal.Enum (Bounded(..), Enum(..)) import GHC.Internal.Float (Floating, RealFloat) import GHC.Internal.Num ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs ===================================== @@ -124,6 +124,7 @@ import {-# SOURCE #-} GHC.Internal.Fingerprint -- import {-# SOURCE #-} GHC.Internal.Debug.Trace (trace) import GHC.Internal.Num( fromInteger ) -- For known-key names +import GHC.Internal.Base( eqString ) -- For known-key names #include "MachDeps.h" ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs ===================================== @@ -36,7 +36,7 @@ module GHC.Internal.IO.Encoding ( argvEncoding ) where -import GHC.Internal.Base (String, return, ($)) +import GHC.Internal.Base (String, return, ($), eqString) import GHC.Internal.Classes (Eq(..)) import GHC.Internal.IO.Exception import GHC.Internal.IO.Buffer ===================================== libraries/ghc-internal/src/GHC/Internal/Magic.hs ===================================== @@ -5,6 +5,10 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines inline etc + {-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} ----------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/Read.hs ===================================== @@ -83,6 +83,7 @@ import GHC.Internal.Tuple (Solo (..)) import GHC.Internal.ByteOrder import GHC.Internal.Control.Monad.Fail( fail ) -- For known-key names +import GHC.Internal.Base( eqString ) -- For known-key names -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with -- parentheses. ===================================== libraries/ghc-internal/src/GHC/Internal/Unsafe/Coerce.hs ===================================== @@ -3,6 +3,9 @@ -- Note [Implementing unsafeCoerce] {-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines unsafeEqualityProof etc + {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/809c39eee41eccd03294fbc3d7bcf24… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/809c39eee41eccd03294fbc3d7bcf24… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/hpc-bc-support] 2 commits: Make HPC work with bytecode interpreter
by Hannes Siebenhandl (＠fendor) 02 Apr '26

02 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 09f4e5e3 by fendor at 2026-04-02T15:01:30+02:00 Make HPC work with bytecode interpreter Add support to generate .tix files from bytecode objects and the bytecode interpreter. Conceptually, we insert HPC ticks into the bytecode similar to how we insert breakpoints. HPC and breakpoints do not share the same tick array but we use a separate tick-array for hpc/breakpoint ticks during bytecode generation. We teach the bytecode interpreter to handle hpc ticks. The implementation is quite trivial, simply increment the counter in the global hpc_ticks array for the respective module. This hpc_ticks array is generated as part of the `CStub`, so we can rely on it existing. A tricky bit is "registering" a bytecode object for HPC instrumentation. In the compiled case, this is achieved via CStub and initializer/finalizers `.init` sections which are called when the executable is run. After the initializers have been invoked, which is before `hs_init_ghc`, we then call `startup_hpc` in `hs_init_ghc` iff any modules were "registered" for hpc instrumentation via `hs_hpc_module`. Since bytecode objects are loaded after starting up GHCi, this workflow doesn't work for supporting `hpc` and the `hpc` run-time is never started, even if a module is added for instrumentation. We fix this issue by employing the same technique as is for `SptEntry`s: * We introduce a new field to `CompiledByteCode`, called `ByteCodeHpcInfo` which contains enough information to call `hs_hpc_module`, allowing us to register the module for `hpc` instrumentation`. * After registering the module, we unconditionally call `startupHpc`, to make sure the .tix file is written. Calling `startupHpc` multiple times is safe. Calling `hs_hpc_module` multiple times for the same module is also safe. If we didn't register the hpc module in this way, evaluating a bytecode object instrumented with `-fhpc` without registering it in the `hpc` run-time will simply not generate any `.tix` files for this bytecode object. However, this shouldn't happen if everything is set up correctly. Closes #27036 - - - - - 9a60e501 by fendor at 2026-04-02T18:24:38+02:00 Add more tests for ghci and -fhpc - - - - - 52 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Binary.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Coverage.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Types/HpcInfo.hs - compiler/GHC/Unit/Module/ModGuts.hs - + libraries/ghci/GHCi/Coverage.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - rts/Disassembler.c - rts/Hpc.c - rts/Interpreter.c - rts/include/rts/Bytecodes.h - testsuite/tests/hpc/Makefile - testsuite/tests/hpc/T17073.stdout → testsuite/tests/hpc/T17073a.stdout - + testsuite/tests/hpc/T17073b.stdout - testsuite/tests/hpc/T20568.stdout → testsuite/tests/hpc/T20568a.stdout - + testsuite/tests/hpc/T20568b.stdout - testsuite/tests/hpc/all.T - testsuite/tests/hpc/fork/Makefile - + testsuite/tests/hpc/function/hpcrun.sh - testsuite/tests/hpc/function/test.T - + testsuite/tests/hpc/function/tough1.script - + testsuite/tests/hpc/function/tough1.stderr - + testsuite/tests/hpc/function/tough1.stdout - testsuite/tests/hpc/function2/test.T - + testsuite/tests/hpc/function2/tough3.script - + testsuite/tests/hpc/ghc_ghci/BytecodeMain.hs - testsuite/tests/hpc/ghc_ghci/Makefile - + testsuite/tests/hpc/ghc_ghci/hpc_ghc_ghci_bytecode.stdout - testsuite/tests/hpc/ghc_ghci/test.T - testsuite/tests/hpc/hpcrun.pl - testsuite/tests/hpc/simple/Makefile - + testsuite/tests/hpc/simple/hpc002.hs - + testsuite/tests/hpc/simple/hpc002.stdout - + testsuite/tests/hpc/simple/hpc003.hs - + testsuite/tests/hpc/simple/hpc003.script - + testsuite/tests/hpc/simple/hpc003.stderr - + testsuite/tests/hpc/simple/hpc003.stdout - testsuite/tests/hpc/simple/test.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/248ccb2e2d6354314dae5a69f7cf2d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/248ccb2e2d6354314dae5a69f7cf2d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sort-usages] 33 commits: Fix assert in Interpreter.c
by Hannes Siebenhandl (＠fendor) 02 Apr '26

02 Apr '26

Hannes Siebenhandl pushed to branch wip/sort-usages at Glasgow Haskell Compiler / GHC Commits: 404b71c1 by Luite Stegeman at 2026-03-27T04:40:49-04:00 Fix assert in Interpreter.c If we skip exactly the number of words on the stack we end up on the first word in the next chunk. - - - - - a85bd503 by Luite Stegeman at 2026-03-27T04:40:49-04:00 Support arbitrary size unboxed tuples in bytecode This stores the size (number of words on the stack) of the next expected tuple in the TSO, ctoi_spill_size field, eliminating the need of stg_ctoi_tN frames for each size. Note: On 32 bit platform there is still a bytecode tuple size limit of 255 words on the stack. Fixes #26946 - - - - - e2209031 by Luite Stegeman at 2026-03-27T04:40:49-04:00 Add specialized frames for small tuples Small tuples are now returned more efficiently to the interpreter. They use one less word of stack space and don't need manipulation of the TSO anymore. - - - - - b26bb2ea by VeryMilkyJoe at 2026-03-27T04:41:38-04:00 Remove backwards compatibility pattern synonym `ModLocation` Fixes #24932 - - - - - 66e5e324 by Vladislav Zavialov at 2026-03-27T04:42:25-04:00 Extend HsExpr with the StarIsType syntax (#26587, #26967) This patch allows kinds of the form `k -> *` and `* -> k` to occur in expression syntax, i.e. to be used as required type arguments. For example: {-# LANGUAGE RequiredTypeArguments, StarIsType #-} x1 = f (* -> * -> *) x2 = f (forall k. k -> *) x3 = f ((* -> *) -> Constraint) Summary of the changes: * Introduce the HsStar constructor of HsExpr and its extension field XStar. It is analogous to HsStarTy in HsType. * Refactor HsStarTy to store the unicode flag as TokStar, defined as type TokStar = EpUniToken "*" "★" -- similar to TokForall, TokRArrow, etc. The token is stored in the extension field and replaces the Bool field. * Extend the `infixexp2` nonterminal to parse `*` as a direct argument of `->`. This is more limited than the full StarIsType syntax, but has the nice property of not conflicting with the multiplication operator `a * b`. Test case: T26967 T26967_tyop - - - - - f8de456f by Sylvain Henry at 2026-03-27T04:43:22-04:00 STM: don't create a transaction in the rhs of catchRetry# (#26028) We don't need to create a transaction for the rhs of (catchRetry#) because contrary to the lhs we don't need to abort it on retry. Moreover it is particularly harmful if we have code such as (#26028): let cN = readTVar vN >> retry tree = c1 `orElse` (c2 `orElse` (c3 `orElse` ...)) atomically tree Because it will stack transactions for the rhss and the read-sets of all the transactions will be iteratively merged in O(n^2) after the execution of the most nested retry. This is the second attempt at implementing this. The first attempt triggered segfaults (#26291) and has been reverted. Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - fcf092dd by Luite Stegeman at 2026-03-27T04:44:17-04:00 Windows: remove StgAsyncIOResult and fix crash/leaks In stg_block_async{_void}, a stack slot was reserved for an StgAsyncIOResult. This slot would be filled by the IO manager upon completion of the async call. However, if the blocked thread was interrupted by an async exception, we would end up in an invalid state: - If the blocked computation was never re-entered, the StgAsyncIOResult would never be freed. - If the blocked computation was re-entered, the thread would find an unitialized stack slot for the StgAsyncIOResult, leading to a crash reading its fields, or freeing the pointer. We fix this by removing the StgAsyncIOResult altogether and writing the result directly to the stack. Fixes #26341 - - - - - 05094993 by Luite Stegeman at 2026-03-27T04:45:12-04:00 Don't refine DEFAULT alt for unary typeclasses A non-DEFAULT data alt for a unary typeclass dictionary would interfere with Unary Class Magic, leading to segfaults. fixes #27071 - - - - - 4ee260cf by sheaf at 2026-03-27T04:46:06-04:00 Fix several oversights in hsExprType This commit fixes several oversights in GHC.Hs.Syn.Type.hsExprType: - The 'RecordCon' case was returning the type of the constructor, instead of the constructor application. This is fixed by using 'splitFunTys'. - The 'ExplicitTuple' case failed to take into account tuple sections, and was also incorrectly handling 1-tuples (e.g. 'Solo') which can be constructed using Template Haskell. - The 'NegApp' case was returning the type of the negation operator, again failing to apply it to the argument. Fixed by using 'funResultTy'. - The 'HsProc' case was computing the result type of the arrow proc block, without taking into account the argument type. Fix that by adding a new field to 'CmdTopTc' that stores the arrow type, so that we can construct the correct result type `arr a b` for `proc (pat :: a) -> (cmd :: b)`. - The 'ArithSeq' and 'NegApp' cases were failing to take into account the result 'HsWrapper', which could e.g. silently drop casts. This is fixed by introducing 'syntaxExpr_wrappedFunResTy' which, on top of taking the result type, applies the result 'HsWrapper'. These fixes are validated by the new GHC API test T26910. Fixes #26910 - - - - - e97232ce by Hai at 2026-03-27T04:47:04-04:00 Parser.y: avoid looking at token with QualifiedDo This changes the behavior of 'hintQualifiedDo' so that the supplied token is not inspected when the QualifiedDo language extension bit is set. - - - - - 9831385b by Vladislav Zavialov at 2026-03-27T17:22:30-04:00 Infix holes in types (#11107) This patch introduces several improvements that follow naturally from refactoring HsOpTy to represent the operator as an HsType, aligning it with the approach taken by OpApp and HsExpr. User-facing changes: 1. Infix holes (t1 `_` t2) are now permitted in types, following the precedent set by term-level expressions. Test case: T11107 2. Error messages for illegal promotion ticks are now reported at more precise source locations. Test case: T17865 Internal changes: * The definition of HsOpTy now mirrors that of OpApp: | HsOpTy (XOpTy p) (LHsType p) (LHsType p) (LHsType p) | OpApp (XOpApp p) (LHsExpr p) (LHsExpr p) (LHsExpr p) This moves us one step closer to unifying HsType and HsExpr. * Ignoring locations, the old pattern match (HsOpTy x prom lhs op rhs) is now written as (HsOpTy x lhs (HsTyVar x' prom op) rhs) but we also handle (HsOpTy x lhs (HsWildCardTy x') rhs) Constructors other than HsTyVar and HsWildCardTy never appear in the operator position. * The various definitions across the compiler have been updated to work with the new representation, drawing inspiration from the term-level pipeline where appropriate. For example, ppr_infix_ty <=> ppr_infix_expr get_tyop <=> get_op lookupTypeFixityRn <=> lookupExprFixityRn (the latter is factored out from rnExpr) Test cases: T11107 T17865 - - - - - 5b6757d7 by mangoiv at 2026-03-27T17:23:19-04:00 ci: build i386 non-validate for deb12 This is a small fix that will unlock ghcup metadata to run, i386 debian 12 was missing as a job. - - - - - cf942119 by Cheng Shao at 2026-03-30T15:24:37-04:00 ghc-boot: remove unused SizedSeq instances and functions This commit removes unused `SizedSeq` instances and functions, only keeping the bits we need for hpc tick sequence for now. - - - - - 22c5b7cc by Cheng Shao at 2026-03-30T15:24:38-04:00 ghci: remove unused GHCi.BinaryArray This patch removes the unused `GHCi.BinaryArray` module from `ghci`. Closes #27108. - - - - - 77abb4ab by Cheng Shao at 2026-03-30T15:25:21-04:00 testsuite: mark T17912 as fragile on Windows T17912 is still fragile on Windows, it sometimes unexpectedly pass in CI. This especially strains our already scarce Windows CI runner resources. Mark it as fragile on Windows for the time being. - - - - - d741a6cc by Andreas Klebinger at 2026-03-31T04:39:33-04:00 Bump minimum shake version for hadrian. We also add the shake version we want to stack.yaml Fixes #26884 - - - - - 5e556f9e by Vladislav Zavialov at 2026-03-31T04:40:16-04:00 Status check for the HsType~HsExpr refactoring (#25121) Add a test case to track the status of a refactoring project within GHC whose goal is to arrive at the following declaration: type HsType = HsExpr The rationale for this is to increase code reuse between the term- and type-level code in the compiler front-end (AST, parser, renamer, type checker). The status report is saved to testsuite/tests/ghc-api/T25121_status.stdout and provides useful insights into what needs to happen to make progress on the ticket. - - - - - acffb1b1 by fendor at 2026-03-31T04:41:02-04:00 Extract Binary instances to `GHC.ByteCode.Binary` - - - - - e2ea8e25 by fendor at 2026-03-31T04:41:02-04:00 Add `seqNonEmpty` for evaluating `NonEmpty a` - - - - - 048b00b7 by fendor at 2026-03-31T04:41:02-04:00 Record `LinkableUsage` instead of `Linkable` in `LoaderState` Retaining a ByteCode `Linkable` after it has been loaded retains its `UnlinkedBCO`, keeping it alive for the remainder of the program. This starts accumulating a lot of `UnlinkedBCO` and memory over time. However, the `Linkable` is merely used to later record its usage in `mkObjectUsage`, which is used for recompilation checking. However, this is incorrect, as the interface file and bytecode objects could be in different states, e.g. the interface changes, but the bytecode library hasn't changed so we don't need to recompile and vice versa. By computing a `Fingerprint` for the `ModuleByteCode`, and recording it in the `LinkableUsage`, we know precisely whether the `ByteCode` object on disk is outdated. Thus, parts of this commit just makes sure that we efficiently compute a `Fingerprint` for `ModuleByteCode` and store it in the on-disk representation of `ModuleByteCode`. We change the `LoaderState` to retain `LinkableUsage`, which is smaller representation of a `Linkable`. This allows us to free the unneeded fields of `Linkable` after linking them. We declare the following memory invariants that this commit implements: * No `LinkablePart` should be retained from `LoaderState`. * `Linkable`s should be unloaded after they have been loaded. These invariants are unfortunately tricky to automatically uphold, so we are simply documenting our assumptions for now. We introduce the `linkable-space` test which makes sure that after loading, no `DotGBC` or `UnlinkedBCO` is retained. ------------------------- Metric Increase: MultiLayerModulesTH_OneShot ------------------------- We allocate a bit more, but the peak number of bytes doesn't change. While a bit unfortunate, accepting the metric increase. We add multiple new performance measurements where we were able to observe the desired memory invariants. Further, we add regression tests to validate that the recompilation checker behaves more correct than before. - - - - - 2d1c1997 by Simon Jakobi at 2026-03-31T04:41:46-04:00 Eliminate dictionary-passing in ListMap operations Mark the ListMap helpers 'INLINABLE' so importing modules can specialise the 'TrieMap (ListMap m)' methods and avoid recursive dictionary-passing. See Note [Making ListMap operations specialisable]. Fixes #27097 - - - - - ed2c6570 by Cheng Shao at 2026-03-31T04:42:33-04:00 testsuite: fix testdir cleanup logic on Windows testdir cleanup is unreliable on Windows (#13162) and despite existing hacks in the driver, new failure mode has occurred. This patch makes it print the warning and carry on when failed to clean up a testdir, instead of reporting a spurious framework failure. See added comment for detailed explanation. - - - - - d9388e29 by Simon Jakobi at 2026-03-31T13:14:59-04:00 Add regression test for #18177 Closes #18177. Assisted-by: Codex - - - - - 6a10045c by mangoiv at 2026-03-31T13:15:43-04:00 ci: allow metric decrease for two tests on i386 There has been a nightly failure on i386 due to a compiler runtime improvement on i386 debian 12. We allow that. Metric Decrease (test_env='i386-linux-deb12'): T12707 T8095 - - - - - 7fbb4fcb by Rodrigo Mesquita at 2026-04-01T12:16:33+00:00 Bump default language edition to GHC2024 As per the accepted ghc-proposal#632 Fixes #26039 - - - - - 5ae43275 by Peng Fan at 2026-04-01T19:01:06-04:00 NCG/LA64: add cmpxchg and xchg primops And append some new instructions for LA664 uarch. Apply fix to cmpxchg-prim by Andreas Klebinger. Suggestions in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/15515 - - - - - 8f95534a by Duncan Coutts at 2026-04-01T19:01:52-04:00 Remove signal-based ticker implementations Fixes issue #27073 All supported platforms should work with the pthreads + nanosleep based ticker implementation. This avoids all the problems with using signals. In practice, all supported platforms were probably using the non-signal tickers already, which is probably why we do not get lots of reports about deadlocks and other weirdness: we were definately using functions that are not async signal safe in the tick handler (such as fflush to flussh the eventlog). Only Solaris was explicitly using the timer_create ticker impl, and even Solaris could probably use the pthreads one (if anyone cared: Solaris is no longer a Teir 3 supported platform). Plausibly the only supported platform that this will change will be AIX, which should now use the pthreads impl. - - - - - 51b32b0d by Duncan Coutts at 2026-04-01T19:01:52-04:00 Tidy up some timer/ticker comments elsewhere - - - - - 7562bcd7 by Duncan Coutts at 2026-04-01T19:01:52-04:00 Remove now-unused install_vtalrm_handler Support function used by both of the signal-based ticker implementations. - - - - - 6da127c7 by Duncan Coutts at 2026-04-01T19:01:52-04:00 No longer probe for timer_create in rts/configure It was only used by the TimerCreate.c ticker impl. - - - - - 3fd490fa by Duncan Coutts at 2026-04-01T19:01:53-04:00 Note that rtsTimerSignal is deprecated. - - - - - 63099b0f by Simon Jakobi at 2026-04-01T19:02:39-04:00 Add perf test for #13960 Closes #13960. - - - - - 6b7ab7d1 by Ian-Woo Kim at 2026-04-02T16:20:35+02:00 determinism: Sort Usages by fingerprint to ensure consistent ordering In some situations it has been observed that the ordering of usages can be non-determinstic in parallel builds. Therefore to be on the safe side we perform a sort on the usages field before writing them to the interface. Fixes #26877 - - - - - 312 changed files: - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compiler/GHC.hs - compiler/GHC/ByteCode/Asm.hs - + compiler/GHC/ByteCode/Binary.hs - compiler/GHC/ByteCode/Instr.hs - + compiler/GHC/ByteCode/Recomp/Binary.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - compiler/GHC/CmmToAsm/LA64/Instr.hs - compiler/GHC/CmmToAsm/LA64/Ppr.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/AddImplicitBinds.hs - compiler/GHC/Data/TrieMap.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Hooks.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Recomp/Types.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/Linker/ByteCode.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Fixity.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Unit/Home/ModInfo.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/Location.hs - compiler/GHC/Unit/Module/Status.hs - compiler/GHC/Utils/Misc.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/Type.hs - compiler/ghc.cabal.in - docs/users_guide/exts/control.rst - docs/users_guide/exts/required_type_arguments.rst - ghc/GHCi/Leak.hs - hadrian/hadrian.cabal - hadrian/stack.yaml - libraries/base/tests/IO/all.T - libraries/ghc-boot/GHC/Data/SizedSeq.hs - − libraries/ghci/GHCi/BinaryArray.hs - libraries/ghci/ghci.cabal.in - − m4/fp_check_timer_create.m4 - rts/Apply.cmm - rts/Continuation.c - rts/ContinuationOps.cmm - rts/HeapStackCheck.cmm - rts/IOManager.c - rts/Interpreter.c - rts/PrimOps.cmm - rts/Printer.c - rts/RaiseAsync.c - rts/RtsSymbols.c - rts/STM.c - rts/STM.h - rts/Schedule.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Threads.h - rts/Timer.c - rts/configure.ac - rts/include/rts/Bytecodes.h - rts/include/rts/Timer.h - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - rts/include/stg/SMP.h - rts/posix/Signals.c - rts/posix/Signals.h - rts/posix/Ticker.c - − rts/posix/ticker/Setitimer.c - − rts/posix/ticker/TimerCreate.c - rts/win32/AsyncMIO.c - rts/win32/AsyncMIO.h - testsuite/driver/testlib.py - testsuite/tests/ado/ado004.hs - testsuite/tests/annotations/should_fail/annfail02.hs - testsuite/tests/annotations/should_fail/annfail02.stderr - testsuite/tests/array/should_run/arr020.hs - + testsuite/tests/bytecode/TLinkable/BCOTemplate.hs - + testsuite/tests/bytecode/TLinkable/LinkableUsage01.stderr - + testsuite/tests/bytecode/TLinkable/LinkableUsage02.stderr - + testsuite/tests/bytecode/TLinkable/Makefile - + testsuite/tests/bytecode/TLinkable/all.T - + testsuite/tests/bytecode/TLinkable/genLinkables.sh - + testsuite/tests/bytecode/TLinkable/linkable-space.hs - + testsuite/tests/bytecode/TLinkable/linkable-space.stdout - + testsuite/tests/bytecode/tuplestress/ByteCode.hs - + testsuite/tests/bytecode/tuplestress/Common.hs-incl - + testsuite/tests/bytecode/tuplestress/Obj.hs - + testsuite/tests/bytecode/tuplestress/TupleStress.hs - + testsuite/tests/bytecode/tuplestress/TupleStress.stdout - + testsuite/tests/bytecode/tuplestress/all.T - + testsuite/tests/concurrent/should_run/T26341.hs - + testsuite/tests/concurrent/should_run/T26341.stdout - + testsuite/tests/concurrent/should_run/T26341a.hs - + testsuite/tests/concurrent/should_run/T26341a.stdout - + testsuite/tests/concurrent/should_run/T26341b.hs - + testsuite/tests/concurrent/should_run/T26341b.stdout - testsuite/tests/concurrent/should_run/all.T - testsuite/tests/core-to-stg/T19700.hs - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/deSugar/should_fail/DsStrictFail.hs - testsuite/tests/deriving/should_compile/T15798b.hs - testsuite/tests/deriving/should_compile/T15798c.hs - testsuite/tests/deriving/should_compile/T15798c.stderr - testsuite/tests/deriving/should_compile/T24955a.hs - testsuite/tests/deriving/should_compile/T24955a.stderr - testsuite/tests/deriving/should_compile/T24955b.hs - testsuite/tests/deriving/should_compile/T24955c.hs - testsuite/tests/deriving/should_fail/T10598_fail4.hs - testsuite/tests/deriving/should_fail/T10598_fail4.stderr - testsuite/tests/deriving/should_fail/T10598_fail5.hs - testsuite/tests/deriving/should_fail/T10598_fail5.stderr - testsuite/tests/dmdanal/sigs/T22241.hs - + testsuite/tests/driver/T18177.hs - testsuite/tests/driver/all.T - testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_recomp_th.stdout - testsuite/tests/driver/recomp016/recomp016.stdout - + testsuite/tests/driver/recomp022/A1.hs - + testsuite/tests/driver/recomp022/A2.hs - + testsuite/tests/driver/recomp022/A3.hs - + testsuite/tests/driver/recomp022/B.hs - + testsuite/tests/driver/recomp022/C.hs - + testsuite/tests/driver/recomp022/Makefile - + testsuite/tests/driver/recomp022/all.T - + testsuite/tests/driver/recomp022/recomp022a.stdout - + testsuite/tests/driver/recomp022/recomp022b.stdout - testsuite/tests/gadt/T20485.hs - + testsuite/tests/ghc-api/T25121_status.hs - + testsuite/tests/ghc-api/T25121_status.stdout - + testsuite/tests/ghc-api/T26910.hs - + testsuite/tests/ghc-api/T26910.stdout - + testsuite/tests/ghc-api/T26910_Input.hs - testsuite/tests/ghc-api/all.T - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/ghci.debugger/scripts/all.T - testsuite/tests/ghci.debugger/scripts/break012.hs - testsuite/tests/ghci.debugger/scripts/break012.stdout - testsuite/tests/ghci/prog-mhu002/all.T - testsuite/tests/ghci/scripts/Makefile - testsuite/tests/ghci/should_run/BinaryArray.hs - testsuite/tests/ghci/should_run/all.T - testsuite/tests/indexed-types/should_compile/T15322.hs - testsuite/tests/indexed-types/should_compile/T15322.stderr - + testsuite/tests/lib/stm/T26028.hs - + testsuite/tests/lib/stm/T26028.stdout - + testsuite/tests/lib/stm/T26291a.hs - + testsuite/tests/lib/stm/T26291a.stdout - + testsuite/tests/lib/stm/T26291b.hs - + testsuite/tests/lib/stm/T26291b.stdout - + testsuite/tests/lib/stm/all.T - testsuite/tests/linear/should_fail/T18888.hs - testsuite/tests/module/T20007.hs - testsuite/tests/module/T20007.stderr - testsuite/tests/module/mod90.hs - testsuite/tests/module/mod90.stderr - testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFail.hs - testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.hs - testsuite/tests/overloadedrecflds/should_fail/all.T - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_fail/ParserNoLambdaCase.hs - testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr - testsuite/tests/parser/should_fail/T16270h.hs - testsuite/tests/parser/should_fail/T16270h.stderr - testsuite/tests/parser/should_fail/T17865.stderr - testsuite/tests/parser/should_fail/readFail001.hs - testsuite/tests/parser/should_fail/readFail001.stderr - testsuite/tests/partial-sigs/should_compile/SomethingShowable.hs - + testsuite/tests/partial-sigs/should_compile/T11107.hs - + testsuite/tests/partial-sigs/should_compile/T11107.stderr - testsuite/tests/partial-sigs/should_compile/all.T - + testsuite/tests/perf/compiler/T13960.hs - testsuite/tests/perf/compiler/all.T - testsuite/tests/plugins/late-plugin/LatePlugin.hs - testsuite/tests/polykinds/T7151.hs - testsuite/tests/polykinds/T7151.stderr - testsuite/tests/polykinds/T7433.hs - testsuite/tests/polykinds/T7433.stderr - testsuite/tests/programs/andy_cherry/test.T - testsuite/tests/rename/should_fail/T10668.hs - testsuite/tests/rename/should_fail/T10668.stderr - testsuite/tests/rename/should_fail/T12681.hs - testsuite/tests/rename/should_fail/T12681.stderr - testsuite/tests/rename/should_fail/T13568.hs - testsuite/tests/rename/should_fail/T13568.stderr - testsuite/tests/rename/should_fail/T13644.hs - testsuite/tests/rename/should_fail/T13644.stderr - testsuite/tests/rename/should_fail/T13847.hs - testsuite/tests/rename/should_fail/T13847.stderr - testsuite/tests/rename/should_fail/T14032c.hs - testsuite/tests/rename/should_fail/T19843l.hs - testsuite/tests/rename/should_fail/T19843l.stderr - testsuite/tests/rename/should_fail/T25901_imp_hq_fail_5.stderr - testsuite/tests/rename/should_fail/T25901_imp_sq_fail_2.stderr - testsuite/tests/rename/should_fail/T5385.hs - testsuite/tests/rename/should_fail/T5385.stderr - testsuite/tests/roles/should_fail/Roles5.hs - testsuite/tests/roles/should_fail/Roles5.stderr - testsuite/tests/showIface/DocsInHiFile.hs - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/DocsInHiFileTH.hs - testsuite/tests/showIface/DocsInHiFileTH.stdout - testsuite/tests/showIface/DocsInHiFileTHExternal.hs - testsuite/tests/showIface/HaddockIssue849.hs - testsuite/tests/showIface/HaddockIssue849.stdout - testsuite/tests/showIface/HaddockOpts.hs - testsuite/tests/showIface/HaddockOpts.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.hs - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/MagicHashInHaddocks.hs - testsuite/tests/showIface/MagicHashInHaddocks.stdout - testsuite/tests/showIface/Makefile - testsuite/tests/showIface/NoExportList.hs - testsuite/tests/showIface/NoExportList.stdout - testsuite/tests/showIface/PragmaDocs.stdout - testsuite/tests/showIface/ReExports.stdout - testsuite/tests/simplCore/T9646/test.T - testsuite/tests/simplCore/should_compile/T21960.hs - testsuite/tests/simplCore/should_compile/T26709.stderr - + testsuite/tests/simplCore/should_run/T27071.hs - + testsuite/tests/simplCore/should_run/T27071.stdout - testsuite/tests/simplCore/should_run/all.T - testsuite/tests/th/TH_Promoted1Tuple.hs - testsuite/tests/th/TH_Roles1.hs - testsuite/tests/typecheck/should_compile/MutRec.hs - testsuite/tests/typecheck/should_compile/T10770a.hs - testsuite/tests/typecheck/should_compile/T11339.hs - testsuite/tests/typecheck/should_compile/T11397.hs - testsuite/tests/typecheck/should_compile/T13526.hs - testsuite/tests/typecheck/should_compile/T18467.hs - testsuite/tests/typecheck/should_compile/T18467.stderr - testsuite/tests/typecheck/should_compile/tc081.hs - testsuite/tests/typecheck/should_compile/tc141.hs - testsuite/tests/typecheck/should_fail/T23427.hs - testsuite/tests/typecheck/should_fail/T6078.hs - testsuite/tests/typecheck/should_fail/T7453.hs - testsuite/tests/typecheck/should_fail/T7453.stderr - testsuite/tests/typecheck/should_fail/T8570.hs - testsuite/tests/typecheck/should_fail/T8570.stderr - testsuite/tests/typecheck/should_fail/tcfail083.hs - testsuite/tests/typecheck/should_fail/tcfail083.stderr - testsuite/tests/typecheck/should_fail/tcfail084.hs - testsuite/tests/typecheck/should_fail/tcfail084.stderr - testsuite/tests/typecheck/should_fail/tcfail094.hs - testsuite/tests/typecheck/should_fail/tcfail094.stderr - testsuite/tests/typecheck/should_run/T1735.hs - testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs - testsuite/tests/typecheck/should_run/T3731.hs - + testsuite/tests/vdq-rta/should_compile/T26967.hs - + testsuite/tests/vdq-rta/should_compile/T26967.stderr - + testsuite/tests/vdq-rta/should_compile/T26967_tyop.hs - + testsuite/tests/vdq-rta/should_compile/T26967_tyop.stderr - testsuite/tests/vdq-rta/should_compile/all.T - testsuite/tests/vdq-rta/should_fail/T24159_type_syntax_th_fail.script - testsuite/tests/warnings/should_fail/CaretDiagnostics1.hs - testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr - testsuite/tests/warnings/should_fail/T24396c.hs - testsuite/tests/warnings/should_fail/T24396c.stderr - utils/check-exact/ExactPrint.hs - utils/deriveConstants/Main.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b8cad7bd8d228a43d31c71353f2ab… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b8cad7bd8d228a43d31c71353f2ab… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sort-usages] 25 commits: Check that shift values are valid
by Hannes Siebenhandl (＠fendor) 02 Apr '26

02 Apr '26

Hannes Siebenhandl pushed to branch wip/sort-usages at Glasgow Haskell Compiler / GHC Commits: aa5dfe67 by Sylvain Henry at 2026-03-26T03:48:56-04:00 Check that shift values are valid In GHC's codebase in non-DEBUG builds we silently substitute shiftL/R with unsafeShiftL/R for performance reasons. However we were not checking that the shift value was valid for unsafeShiftL/R, leading to wrong computations, but only in non-DEBUG builds. This patch adds the necessary checks and reports an error when a wrong shift value is passed. - - - - - c8a7b588 by Sylvain Henry at 2026-03-26T03:48:56-04:00 Implement basic value range analysis (#25718) Perform basic value range analysis to try to determine at compile time the result of the application of some comparison primops (ltWord#, etc.). This subsumes the built-in rewrite rules used previously to check if one of the comparison argument was a bound (e.g. (x :: Word8) <= 255 is always True). Our analysis is more powerful and handles type conversions: e.g. word8ToWord x <= 255 is now detected as always True too. We also use value range analysis to filter unreachable alternatives in case-expressions. To support this, we had to allow case-expressions for primitive types to not have a DEFAULT alternative (as was assumed before and checked in Core lint). - - - - - a5ec467e by ARATA Mizuki at 2026-03-26T03:49:49-04:00 rts: Align stack to 64-byte boundary in StgRun on x86 When LLVM spills AVX/AVX-512 vector registers to the stack, it requires 32-byte (__m256) or 64-byte (__m512) alignment. If the stack is not sufficiently aligned, LLVM inserts a realignment prologue that reserves %rbp as a frame pointer, conflicting with GHC's use of %rbp as an STG callee-saved register and breaking the tail-call-based calling convention. Previously, GHC worked around this by lying to LLVM about the stack alignment and rewriting aligned vector loads/stores (VMOVDQA, VMOVAPS) to unaligned ones (VMOVDQU, VMOVUPS) in the LLVM Mangler. This had two problems: - It did not extend to AVX-512, which requires 64-byte alignment. (#26595) - When Haskell calls a C function that takes __m256/__m512 arguments on the stack, the callee requires genuine alignment, which could cause a segfault. (#26822) This patch genuinely aligns the stack to 64 bytes in StgRun by saving the original stack pointer before alignment and restoring it in StgReturn. We now unconditionally advertise 64-byte stack alignment to LLVM for all x86 targets, making rewriteAVX in the LLVM Mangler unnecessary. STG_RUN_STACK_FRAME_SIZE is increased from 48 to 56 bytes on non-Windows x86-64 to store the saved stack pointer. Closes #26595 and #26822 Co-Authored-By: Claude Opus 4.5 <noreply(a)anthropic.com> - - - - - 661da815 by Teo Camarasu at 2026-03-26T03:50:33-04:00 ghc-internal: Float Generics to near top of module graph We remove GHC.Internal.Generics from the critical path of the `ghc-internal` module graph. GHC.Internal.Generics used to be in the middle of the module graph, but now it is nearer the top (built later). This change thins out the module graph and allows us to get rid of the ByteOrder hs-boot file. We implement this by moving Generics instances from the module where the datatype is defined to the GHC.Internal.Generics module. This trades off increasing the compiled size of GHC.Internal.Generics with reducing the dependency footprint of datatype modules. Not all instances are moved to GHC.Internal.Generics. For instance, `GHC.Internal.Control.Monad.Fix` keeps its instance as it is one of the very last modules compiled in `ghc-internal` and so inverting the relationship here would risk adding GHC.Internal.Generics back onto the critical path. We also don't change modules that are re-exported from the `template-haskell` or `ghc-heap`. This is done to make it easy to eventually move `Generics` to `base` once something like #26657 is implemented. Resolves #26930 Metric Decrease: T21839c - - - - - 45428f88 by sheaf at 2026-03-26T03:51:31-04:00 Avoid infinite loop in deep subsumption This commit ensures we only unify after we recur in the deep subsumption code in the FunTy vs non-FunTy case of GHC.Tc.Utils.Unify.tc_sub_type_deep, to avoid falling into an infinite loop. See the new Wrinkle [Avoiding a loop in tc_sub_type_deep] in Note [FunTy vs non-FunTy case in tc_sub_type_deep] in GHC.Tc.Utils.Unify. Fixes #26823 Co-authored-by: simonpj <simon.peytonjones(a)gmail.com> - - - - - 2823b039 by Ian Duncan at 2026-03-26T03:52:21-04:00 AArch64: fix MOVK regUsageOfInstr to mark dst as both read and written MOVK (move with keep) modifies only a 16-bit slice of the destination register, so the destination is both read and written. The register allocator must know this to avoid clobbering live values. Update regUsageOfInstr to list the destination in both src and dst sets. No regression test: triggering the misallocation requires specific register pressure around a MOVK sequence, which is difficult to reliably provoke from Haskell source. - - - - - 57b7878d by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #12002 Closes #12002. - - - - - c8f9df2d by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #12046 Closes #12046. Co-authored-by: Andreas Klebinger <klebinger.andreas(a)gmx.at> - - - - - 615d72ac by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #13180 Closes #13180. - - - - - 423eebcf by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #11141 Closes #11141. - - - - - 286849a4 by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #11505 Closes #11505. - - - - - 7db149d9 by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression perf test for #13820 Closes #13820. - - - - - e73c4adb by Simon Jakobi at 2026-03-26T03:53:07-04:00 Add regression test for #10381 Closes #10381. - - - - - 5ebcfb57 by Benjamin Maurer at 2026-03-26T03:54:02-04:00 Generate assembly on x86 for word2float (#22252) We used to emit C function call for MO_UF_Conv primitive. Now emits direct assembly instead. Co-Authored-By: Sylvain Henry <sylvain(a)haskus.fr> Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 5b550754 by Matthew Pickering at 2026-03-26T03:54:51-04:00 rts: forward clone-stack messages after TSO migration MSG_CLONE_STACK assumed that the target TSO was still owned by the capability that received the message. This is not always true: the TSO can migrate before the inbox entry is handled. When that happened, handleCloneStackMessage could clone a live stack from the wrong capability and use the wrong capability for allocation and performTryPutMVar, leading to stack sanity failures such as checkStackFrame: weird activation record found on stack. Fix this by passing the current capability into handleCloneStackMessage, rechecking msg->tso->cap at handling time, and forwarding the message if the TSO has migrated. Once ownership matches, use the executing capability consistently for cloneStack, rts_apply, and performTryPutMVar. Fixes #27008 - - - - - ef0a1bd2 by mangoiv at 2026-03-26T03:55:34-04:00 release tracking: adopt release tracking ticket from #16816 - - - - - a7f40fd9 by mangoiv at 2026-03-26T03:55:34-04:00 release tracking: add a release tracking ticket Brings the information in the release tracking ticket up to date with https://gitlab.haskell.org/ghc/ghc-hq/-/blob/main/release-management.mkd Resolves #26691 - - - - - 161d3285 by Teo Camarasu at 2026-03-26T03:56:18-04:00 Revert "Set default eventlog-flush-interval to 5s" Flushing the eventlog forces a synchronisation of all the capabilities and there was a worry that this might lead to a performance cost for some highly parallel workloads. This reverts commit 66b96e2a591d8e3d60e74af3671344dfe4061cf2. - - - - - 36eed985 by Cheng Shao at 2026-03-26T03:57:03-04:00 ghc-boot: move GHC.Data.SmallArray to ghc-boot This commit moves `GHC.Data.SmallArray` from the `ghc` library to `ghc-boot`, so that it can be used by `ghci` as well: - The `Binary` (from `ghc`) instance of `SmallArray` is moved to `GHC.Utils.Binary` - Util functions `replicateSmallArrayIO`, `mapSmallArrayIO`, `mapSmallArrayM_`, `imapSmallArrayM_` , `smallArrayFromList` and `smallArrayToList` are added - The `Show` instance is added - The `Binary` (from `binary`) instance is added - - - - - fdf828ae by Cheng Shao at 2026-03-26T03:57:03-04:00 compiler: use `Binary` instance of `BCOByteArray` for bytecode objects This commit defines `Binary` (from `compiler`) instance of `BCOByteArray` which serializes the underlying buffer directly, and uses it directly in bytecode object serialization. Previously we reuse the `Binary` (from `binary`) instance, and this change allows us to avoid double-copying via an intermediate `ByteString` when using `put`/`get` in `binnary`. Also see added comment for explanation. - - - - - 3bf62d0a by Cheng Shao at 2026-03-26T03:57:03-04:00 ghci: use SmallArray directly in ResolvedBCO This patch makes ghci use `SmallArray` directly in `ResolvedBCO` when applicable, making the memory representation more compact and reducing marshaling overhead. Closes #27058. - - - - - 3d6492ce by Wen Kokke at 2026-03-26T03:57:53-04:00 Fix race condition between flushEventLog and start/endEventLogging. This commit changes `flushEventLog` to acquire/release the `state_change` mutex to prevent interleaving with `startEventLogging` and `endEventLogging`. In the current RTS, `flushEventLog` _does not_ acquire this mutex, which may lead to eventlog corruption on the following interleaving: - `startEventLogging` writes the new `EventLogWriter` to `event_log_writer`. - `flushEventLog` flushes some events to `event_log_writer`. - `startEventLogging` writes the eventlog header to `event_log_writer`. This causes the eventlog to be written out in an unreadable state, with one or more events preceding the eventlog header. This commit renames the old function to `flushEventLog_` and defines `flushEventLog` simply as: ```c void flushEventLog(Capability **cap USED_IF_THREADS) { ACQUIRE_LOCK(&state_change_mutex); flushEventLog_(cap); RELEASE_LOCK(&state_change_mutex); } ``` The old function is still needed internally within the compilation unit, where it is used in `endEventLogging` in a context where the `state_change` mutex has already been acquired. I've chosen to mark `flushEventLog_` as static and let other uses of `flushEventLog` within the RTS refer to the new version. There is one use in `hs_init_ghc` via `flushTrace`, where the new locking behaviour should be harmless, and one use in `handle_tick`, which I believe was likely vulnerable to the same race condition, so the new locking behaviour is desirable. I have not added a test. The behaviour is highly non-deterministic and requires a program that concurrently calls `flushEventLog` and `startEventLogging`/`endEventLogging`. I encountered the issue while developing `eventlog-socket` and within that context have verified that my patch likely addresses the issue: a test that used to fail within the first dozen or so runs now has been running on repeat for several hours. - - - - - 7b9a75f0 by Phil Hazelden at 2026-03-26T03:58:37-04:00 Fix build with werror on glibc 2.43. We've been defining `_XOPEN_SOURCE` and `_POSIX_C_SOURCE` to the same values as defined in glibc prior to 2.43. But in 2.43, glibc changes them to new values, which means we get a warning when redefining them. By `#undef`ing them first, we no longer get a warning. Closes #27076. - - - - - fe6e76c5 by Tobias Haslop at 2026-03-26T03:59:30-04:00 Fix broken Haddock link to Bifunctor class in description of Functor class - - - - - 7b8cad7b by Ian-Woo Kim at 2026-03-26T10:05:09+01:00 determinism: Sort Usages by fingerprint to ensure consistent ordering In some situations it has been observed that the ordering of usages can be non-determinstic in parallel builds. Therefore to be on the safe side we perform a sort on the usages field before writing them to the interface. Fixes #26877 - - - - - 112 changed files: - + .gitlab/issue_templates/release_tracking.md - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Cmm/Node.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToLlvm.hs - compiler/GHC/CmmToLlvm/Config.hs - compiler/GHC/CmmToLlvm/Mangler.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - + compiler/GHC/Core/Opt/Range.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Driver/Config/CmmToLlvm.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Prelude/Basic.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Utils.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in - docs/users_guide/9.16.1-notes.rst - compiler/GHC/Data/SmallArray.hs → libraries/ghc-boot/GHC/Data/SmallArray.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs - − libraries/ghc-internal/src/GHC/Internal/ByteOrder.hs-boot - libraries/ghc-internal/src/GHC/Internal/Char.hs - libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Data/Monoid.hs - libraries/ghc-internal/src/GHC/Internal/Data/Semigroup/Internal.hs - libraries/ghc-internal/src/GHC/Internal/Data/Traversable.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs - libraries/ghc-internal/src/GHC/Internal/Generics.hs - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs - libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/Unicode/Bits.hs - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/ResolvedBCO.hs - rts/CloneStack.c - rts/CloneStack.h - rts/Messages.c - rts/RtsFlags.c - rts/StgCRun.c - rts/eventlog/EventLog.c - rts/include/rts/Constants.h - rts/include/rts/PosixSource.h - testsuite/tests/codeGen/should_run/Word2Float32.hs - testsuite/tests/codeGen/should_run/Word2Float32.stdout - testsuite/tests/codeGen/should_run/Word2Float64.hs - testsuite/tests/codeGen/should_run/Word2Float64.stdout - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/driver/recomp016/recomp016.stdout - testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout - testsuite/tests/ghci/scripts/T10963.stderr - testsuite/tests/ghci/scripts/ghci064.stdout - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - + testsuite/tests/parser/should_compile/T12002.hs - + testsuite/tests/parser/should_compile/T12002.stderr - testsuite/tests/parser/should_compile/all.T - + testsuite/tests/perf/compiler/T13820.hs - testsuite/tests/perf/compiler/all.T - + testsuite/tests/rebindable/T10381.hs - testsuite/tests/rebindable/all.T - testsuite/tests/rts/all.T - + testsuite/tests/rts/cloneThreadStackMigrating.hs - + testsuite/tests/simd/should_run/StackAlignment32.hs - + testsuite/tests/simd/should_run/StackAlignment32.stdout - + testsuite/tests/simd/should_run/StackAlignment32_main.c - + testsuite/tests/simd/should_run/StackAlignment64.hs - + testsuite/tests/simd/should_run/StackAlignment64.stdout - + testsuite/tests/simd/should_run/StackAlignment64_main.c - testsuite/tests/simd/should_run/all.T - + testsuite/tests/simplCore/should_compile/T19166.hs - + testsuite/tests/simplCore/should_compile/T19166.stderr - + testsuite/tests/simplCore/should_compile/T25718.hs - + testsuite/tests/simplCore/should_compile/T25718.stderr - + testsuite/tests/simplCore/should_compile/T25718a.hs - + testsuite/tests/simplCore/should_compile/T25718a.stderr - + testsuite/tests/simplCore/should_compile/T25718b.hs - + testsuite/tests/simplCore/should_compile/T25718b.stderr - + testsuite/tests/simplCore/should_compile/T25718c.hs - + testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-32 - + testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-64 - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/typecheck/T13180/T13180.hs - + testsuite/tests/typecheck/T13180/T13180.hs-boot - + testsuite/tests/typecheck/T13180/T13180.stderr - + testsuite/tests/typecheck/T13180/T13180A.hs - + testsuite/tests/typecheck/T13180/all.T - + testsuite/tests/typecheck/should_compile/T11141.hs - + testsuite/tests/typecheck/should_compile/T11141.stderr - + testsuite/tests/typecheck/should_compile/T11505Bar.hs - + testsuite/tests/typecheck/should_compile/T11505Foo.hs - + testsuite/tests/typecheck/should_compile/T11505Foo.hs-boot - + testsuite/tests/typecheck/should_compile/T12046.hs - testsuite/tests/typecheck/should_compile/T26225.hs - testsuite/tests/typecheck/should_compile/all.T - + testsuite/tests/typecheck/should_fail/T26823.hs - + testsuite/tests/typecheck/should_fail/T26823.stderr - testsuite/tests/typecheck/should_fail/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0c71039c2300ba4a9c2a9458440097… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0c71039c2300ba4a9c2a9458440097… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26868] Major refactor of free-variable functions
by Rodrigo Mesquita (＠alt-romes) 02 Apr '26

02 Apr '26

Rodrigo Mesquita pushed to branch wip/T26868 at Glasgow Haskell Compiler / GHC Commits: 568de024 by Simon Peyton Jones at 2026-04-02T15:05:57+01:00 Major refactor of free-variable functions For some time we have had two free-variable mechanims for types: * The "FV" mechanism, embodied in GHC.Utils.FV, which worked OK, but was fragile where eta-expansion was concerned. * The TyCoFolder mechanism, using a one-shot EndoOS accumulator I finally got tired of this and refactored the whole thing, thereby addressing #27080. Now we have * `GHC.Types.Var.FV`, which has a composable free-variable result type, very much in the spirit of the old `FV`, but much more robust. (It uses the "one shot trick".) * GHC.Core.TyCo.FVs now has just one technology for free variables. All this led to a lot of renaming. There are couple of error-message changes. The change in T18451 makes an already-poor error message even more mysterious. But it really needs a separate look. We also now traverse the AST in a different order leading to a different but still deterministic order for FVs and test output has been adjusted accordingly. - - - - - 84 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Expr.hs-boot - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Lit.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Splice.hs-boot - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Types/Name/Set.hs - + compiler/GHC/Types/Var/FV.hs - compiler/GHC/Types/Var/Set.hs - compiler/GHC/Utils/EndoOS.hs - − compiler/GHC/Utils/FV.hs - compiler/ghc.cabal.in - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/cpranal/should_compile/T18401.stderr - testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/partial-sigs/should_compile/T10403.stderr - testsuite/tests/partial-sigs/should_compile/T12844.stderr - testsuite/tests/partial-sigs/should_compile/T15039a.stderr - testsuite/tests/partial-sigs/should_compile/T15039b.stderr - testsuite/tests/partial-sigs/should_compile/T15039c.stderr - testsuite/tests/partial-sigs/should_compile/T15039d.stderr - testsuite/tests/partial-sigs/should_fail/T10999.stderr - testsuite/tests/partial-sigs/should_fail/T12634.stderr - testsuite/tests/polykinds/T15789.stderr - testsuite/tests/polykinds/T18451.stderr - testsuite/tests/polykinds/T7328.stderr - testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr - testsuite/tests/simplCore/should_compile/T24229a.stderr - testsuite/tests/simplCore/should_compile/T24229b.stderr - testsuite/tests/simplCore/should_compile/T24359a.stderr - testsuite/tests/simplCore/should_compile/T26116.stderr - testsuite/tests/simplCore/should_compile/T4908.stderr - testsuite/tests/simplCore/should_compile/spec-inline.stderr - testsuite/tests/typecheck/no_skolem_info/T20063.stderr - testsuite/tests/typecheck/should_compile/T25180.stderr - testsuite/tests/typecheck/should_compile/free_monad_hole_fits.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T12589.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T17773.stderr - testsuite/tests/typecheck/should_fail/T2846b.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/568de0244cf9ffd9c14903a32cfb5ef… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/568de0244cf9ffd9c14903a32cfb5ef… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26878] Simplify mkTick
by sheaf (＠sheaf) 02 Apr '26

02 Apr '26

sheaf pushed to branch wip/T26878 at Glasgow Haskell Compiler / GHC Commits: df3a4143 by sheaf at 2026-04-02T15:12:54+02:00 Simplify mkTick This commit simplifies 'GHC.Core.Utils.mkTick', removing the accumulating parameter 'rest' which was suspiciously treating a bunch of different ticks as a group, and moving the group as a whole around the AST, ignoring that the ticks in the group might have different placement properties. Also adds Note [Pushing SCCs inwards] which clarifies the logic for pushing SCCs into lambdas, constructor applications, and dropping SCCs around non-function variables (in particular the treatment of splittable ticks). A few other changes are also implemented: - simplify 'can_split' predicate (no functional change) - drop profiling ticks around coercions, fixing #26941 and #27121 - combine profiling ticks into one when possible Fixes #26878, #26941 and #27121 Co-authored-by: simonpj <simon.peytonjones(a)gmail.com> - - - - - 9 changed files: - compiler/GHC/Core/Utils.hs - compiler/GHC/Types/Tickish.hs - libraries/ghc-heap/tests/tso_and_stack_closures.hs - + testsuite/tests/profiling/should_compile/T27121.hs - + testsuite/tests/profiling/should_compile/T27121_aux.hs - testsuite/tests/profiling/should_compile/all.T - + testsuite/tests/simplCore/should_compile/T26941.hs - + testsuite/tests/simplCore/should_compile/T26941_aux.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -303,101 +303,262 @@ mkCast expr co * * ********************************************************************* -} --- | Wraps the given expression in the source annotation, dropping the --- annotation if possible. +-- | Wraps the given expression in a Tick, floating the tick as far into +-- the AST as possible in order to try to satisfy the tick's desired placement +-- properties (as per Note [Tickish placement] in GHC.Types.Tickish). +-- +-- Prefer using 'mkTick' over explicit use of the 'Tick' constructor. +-- +-- Also performs small on-the-fly optimisations: +-- +-- * Eliminate unnecessary ticks by either absorbing them into existing ones +-- or dropping them if that is valid (e.g. dropping profiling ticks around +-- types, coercions and literals). +-- * Split profiling ticks into counting/scoping parts so that the two parts +-- can be placed independently into the AST. mkTick :: CoreTickish -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' id orig_expr +mkTick t orig_expr = mkTick' orig_expr where -- Some ticks (cost-centres) can be split in two, with the -- non-counting part having laxer placement properties. - canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + -- See Note [Scoping ticks and counting ticks] in GHC.Types.Tickish. + can_split = tickishCanSplit t - -- mkTick' handles floating of ticks *into* the expression. - mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with) - -- Always a composition of (Tick t) wrappers - -> CoreExpr -- Current expression - -> CoreExpr - -- So in the call (mkTick' rest e), the expression - -- (rest e) - -- has the same type as e - -- Returns an expression equivalent to (Tick t (rest e)) - mkTick' rest expr = case expr of - -- Float ticks into unsafe coerce the same way we would do with a cast. - Case scrut bndr ty alts@[Alt ac abs _rhs] - | Just rhs <- isUnsafeEqualityCase scrut bndr alts - -> Case scrut bndr ty [Alt ac abs (mkTick' rest rhs)] - - -- Cost centre ticks should never be reordered relative to each - -- other. Therefore we can stop whenever two collide. + -- mkTick' handles floating of tick `t` *into* the expression. + mkTick' :: CoreExpr -> CoreExpr + mkTick' expr = case expr of Tick t2 e - | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr - - -- Otherwise we assume that ticks of different placements float - -- through each other. - | tickishPlace t2 /= tickishPlace t -> Tick t2 $ mkTick' rest e - - -- For annotations this is where we make sure to not introduce - -- redundant ticks. - | tickishContains t t2 -> mkTick' rest e -- Drop t2 - | tickishContains t2 t -> rest e -- Drop t - | otherwise -> mkTick' (rest . Tick t2) e - - -- Ticks don't care about types, so we just float all ticks - -- through them. Note that it's not enough to check for these - -- cases top-level. While mkTick will never produce Core with type - -- expressions below ticks, such constructs can be the result of - -- unfoldings. We therefore make an effort to put everything into - -- the right place no matter what we start with. - Cast e co -> mkCast (mkTick' rest e) co - Coercion co -> Tick t $ rest (Coercion co) + + -- Common up ticks when possible, including profiling ticks that + -- share a cost centre and source notes that subsume one another. + | Just t' <- combineTickish_maybe t t2 + -> mkTick t' e + + -- Profiling ticks for different cost centres should never be reordered + -- relative to each other. Therefore, we stop whenever two collide. + | ProfNote {} <- t + , ProfNote {} <- t2 + -> Tick t expr + + -- Ticks of different placements float through each other, so that each + -- tick can be floated into its expected position in the AST. + -- See Note [Tickish placement] in GHC.Types.Tickish. + | tickishPlace t2 /= tickishPlace t + -> Tick t2 $ mkTick' e Lam x e -- Always float through type lambdas. Even for non-type lambdas, -- floating is allowed for all but the most strict placement rule. | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime - -> Lam x $ mkTick' rest e + -> Lam x $ mkTick' e - -- If it is both counting and scoped, we split the tick into its - -- two components, often allowing us to keep the counting tick on - -- the outside of the lambda and push the scoped tick inside. - -- The point of this is that the counting tick can probably be - -- floated, and the lambda may then be in a position to be - -- beta-reduced. - | canSplit - -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + -- Push SCCs into lambdas. + -- See (PSCC2) in Note [Pushing SCCs inwards]. + | can_split + -> Tick (mkNoScope t) $ Lam x $ mkTick (mkNoCount t) e App f arg - -- Always float through type applications. + -- All ticks float inwards through non-runtime arguments, as per + -- Note [Tickish placement] in GHC.Types.Tickish. | not (isRuntimeArg arg) - -> App (mkTick' rest f) arg + -> App (mkTick' f) arg - -- We can also float through constructor applications, placement - -- permitting. Again we can split. - | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) + -- Push SCCs into saturated constructor applications. + -- See (PSCC3) in Note [Pushing SCCs inwards]. + | isSaturatedConApp expr + , tickishPlace t == PlaceCostCentre || can_split -> if tickishPlace t == PlaceCostCentre - then rest $ tickHNFArgs t expr - else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + then tickHNFArgs t expr + else Tick (mkNoScope t) $ tickHNFArgs (mkNoCount t) expr + + -- See Note [No ticks around types or coercions] + e@(Coercion {}) -> e + e@(Type {}) -> e + -- Don't wrap static data in a tick which compiles to code, + -- as the code will never be run. + e@(Lit {}) | tickishIsCode t -> e + + -- All ticks can be floated through casts, as per Note [Tickish placement]. + Cast e co -> mkCast (mkTick' e) co + + -- Treat 'unsafeCoerce' as if it was a cast: float all ticks inwards. + -- See Note [Push ticks into unsafeCoerce] + Case scrut bndr ty alts@[Alt ac abs _rhs] + | Just rhs <- isUnsafeEqualityCase scrut bndr alts + -> Case scrut bndr ty [Alt ac abs (mkTick' rhs)] Var x - | notFunction && tickishPlace t == PlaceCostCentre - -> rest expr -- Drop t - | notFunction && canSplit - -> Tick (mkNoScope t) $ rest expr - where - -- SCCs can be eliminated on variables provided the variable - -- is not a function. In these cases the SCC makes no difference: - -- the cost of evaluating the variable will be attributed to its - -- definition site. When the variable refers to a function, however, - -- an SCC annotation on the variable affects the cost-centre stack - -- when the function is called, so we must retain those. - notFunction = not (isFunTy (idType x)) - - Lit{} + -- Don't drop any ticks around a function + | isFunTy (idType x) + -> Tick t expr + -- Drop SCCs around non-function variables. + -- See (PSCC1) in Note [Pushing SCCs inwards]. | tickishPlace t == PlaceCostCentre - -> rest expr -- Drop t + -> -- Drop pure SCC ticks: scc<foo> (x :: Int) ==> x + expr + | can_split + -> -- Drop the scoping part of the tick, but keep the counting part. + Tick (mkNoScope t) expr + + -- Catch-all: annotate where we stand. + -- In particular (but not only): Let, most Cases. + _other -> Tick t expr + +{- Note [Pushing SCCs inwards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Amongst all ticks, SCCs have the laxest placement properties (PlaceCostCentre, +as described in Note [Tickish placement] GHC.Types.Tickish): + + (PSCC1) SCCs around non-function variables can be eliminated. + The cost of evaluating the variable will be attributed to its definition + site, so the SCC makes no difference. Example: + + scc<foo> (x :: Int) ==> x + + NB: this is only valid when the variable is not a function. For example, in: + + scc<foo> (f :: Int -> Int) + + we must retain the cost centre annotation, as it affects the cost-centre + pointer when the function is called. Discarding the SCC in this case would + defeat the profiling mechanism entirely! + + (PSCC2) SCCs can be pushed into lambdas. + + scc<foo> (\x -> e) ==> \x -> scc<foo> e + + (PSCC3) We can push SCCs into (saturated) constructor applications. + For example, for an arity 2 data constructor 'D': + + scc<foo> (D e1 e2) ==> D (scc<foo> e1) (scc<foo> e2) + +Now, two kinds of ticks contain SCCs: + + - bare SCCs (i.e. ProfNote with profNoteCounts = False, profNoteScopes = True) + - profiling ticks that both count and scope + +The above explanation deals with bare SCCs. When handling profiling ticks that +both count and scope, we can split tick into two, so that the scoping part can +be pushed inwards (or even discarded). Specifically, we perform the following +transformations: + + (PSCC1) Drop the SCC around non-function variables, keeping only the counting + part: + + scctick<foo> (x :: Int) ==> tick<foo> x + + (PSCC2) Push the SCC inside lambdas: + + scctick<foo> (\x. e) ==> tick<foo> (\x. scc<foo> e) + + NB: we must keep the counting part outside the lambda, in order to preserve + tick counter tallies – it would not be sound to push the counting part inside. - -- Catch-all: Annotate where we stand - _any -> Tick t $ rest expr + (PSCC3) Push the SCC inside saturated contructor applications. + + scctick<foo> (D e1 e2) ==> tick<foo> (D (scc<foo> e1) (scc<foo> e2)) + +The benefit of these transformation is that the counting part, tick<foo>, can +likely be floated out of the way, which may expose additional optimisation +opportunities. For example, for (PSCC2): + + (scctick<foo> (\x. e)) arg + + ==>{PSCC2} + + (tick<foo> (\x. scc<foo> e)) arg + + ==>{GHC.Core.Opt.FloatOut.floatExpr, because 'tick<foo>' has no scope} + + tick<foo> ((\x. scc<foo> e) arg) + + ==>{beta reduction} + + tick<foo> (let x = arg in scc<foo> e) + +For (PSCC3): + + case (scctick<foo> (Just x)) of { Nothing -> 0; Just y -> y + 1 } + + ==>{PSCC3} + + case (tick<foo> (Just (scc<foo> x))) of { Nothing -> 0; Just y -> y + 1 } + + ==>{GHC.Core.Opt.FloatOut.floatExpr, because 'tick<foo>' has no scope} + + tick<foo> (case Just (scc<foo> x) of { Nothing -> 0; Just y -> y + 1 }) + + ==>{case of known constructor} + + tick<foo> (let y = scc<foo> x in y + 1) + +Note [Push ticks into unsafeCoerce] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #25212, we had a program of the form: + + data Box = Box Any + asBox :: a -> Box + asBox x = {-# SCC asBox #-} Box (unsafeCoerce x) + +As per Note [Implementing unsafeCoerce] in GHC.Internal.Unsafe.Coerce, the call +to `unsafeCoerce` turns into + + case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> x |> Sub co + +The worker for 'asBox' is then of the form: + + $wasBox = \@a (x :: a) -> + (# case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> x |> Sub co + #) + +When inserting the SCC, we push it into the constructor as per (PSCC3) in +Note [Pushing SCCs inwards], so we get: + + $wasBox = \@a (x :: a) -> + tick<asBox> + (# scc<asBox> + case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> x |> Sub co + #) + +Now, if we don't push the SCC tick into the case statement, Core Prep will +see an expression like 'MkSolo# (scc<asBox> ...)', which it will ANFise to +'let x = scc<asBox> ... in MkSolo# x', creating an unwanted thunk in the process. + +So the strategy is to treat this 'unsafeEqualityProof' case statement as if it +was a cast. We thus push the SCC into the RHS of the pattern match: + + $wasBox = \@a (x :: a) -> + tick<asBox> + (# case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> scc<asBox> x |> Sub co + #) + +Then the SCC completely evaporates, as per (PSCC1) in Note [Pushing SCCs inwards]. + +Note [No ticks around types or coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It doesn't make much sense to put a tick around a type or a coercion, as both +types and coercions are erased in the end. + +In fact, it is quite dangerous to add a tick around types or coercions, because +the optimiser does not robustly look through ticks: + + - 'GHC.Core.SimpleOpt.simple_bind_pair' does not look through ticks when + looking at the RHS to decide whether it is a Type or Coercion, + - 'GHC.Core.Opt.Simplify.Iteration.completeBind' does not look through ticks + when looking at the RHS of an CoVar binding. + +This means it is vital to drop ticks around types/coercions: + + - (#26941) Core Lint rejects bindings of the form "let co = tick ..." + in which the LHS is a CoVar and the RHS is a ticked Coercion. + - (#27121) The simplifier mis-handles ticked coercion bindings, which can + result in 'lookupIdSubst' panics (due to failing to extend the substitution + with a coercion). +-} mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks @@ -2545,8 +2706,8 @@ exprIsTickedString = isJust . exprIsTickedString_maybe exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString exprIsTickedString_maybe (Lit (LitString bs)) = Just bs exprIsTickedString_maybe (Tick t e) - -- we don't tick literals with CostCentre ticks, compare to mkTick - | tickishPlace t == PlaceCostCentre = Nothing + -- Shortcut: ticks with code never wrap literals (compare with 'mkTick') + | tickishIsCode t = Nothing | otherwise = exprIsTickedString_maybe e exprIsTickedString_maybe _ = Nothing ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -17,6 +17,7 @@ module GHC.Types.Tickish ( TickishPlacement(..), tickishPlace, tickishContains, + combineTickish_maybe, -- * Breakpoint tick identifiers BreakpointId(..), BreakTickIndex @@ -261,8 +262,12 @@ Ticks have two independent attributes: See Note [Scoped ticks] +Note that profiling notes which both count and scope can be split into two +separate ticks, one that counts and doesn't scope and one that scopes and doesn't +count; see 'tickishCanSplit', 'mkNoCount' and 'mkNoScope'. + Note [Counting ticks] -~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~ The following ticks count: - ProfNote ticks with profNoteCounts = True - HPC ticks @@ -290,7 +295,7 @@ sharing, so in practice the actual number of ticks may vary, except that we never change the value from zero to non-zero or vice-versa. Note [Scoped ticks] -~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~ The following ticks are scoped: - ProfNote ticks with profNoteScope = True - Breakpoints @@ -375,6 +380,61 @@ Whether we are allowed to float in additional cost depends on the tick: While these transformations are legal, we want to make a best effort to only make use of them where it exposes transformation opportunities. + +Note [Tickish placement] +~~~~~~~~~~~~~~~~~~~~~~~~ +The placement behaviour of ticks (i.e. which nodes we want the tick to be placed +around in the AST) is governed by 'TickishPlacement'. +From most restrictive to least restrictive placement rules: + + - PlaceRuntime: counting ticks. + + Ticks with 'PlaceRuntime' placement want to be placed around run-time + expressions. They can be moved through pure compile-time constructs such as + other type arguments, casts, or type lambdas: + + tick <t> (f @ty) ==> (tick <t> f) @ty + tick <t> (e |> co) ==> (tick <t> e) |> co + tick <t> (/\a. e) ==> /\a. tick <t> e + + This is the most restrictive placement rule for ticks, as all tickishs have + in common that they want to track runtime behaviour. + + Any tick that counts (see Note [Counting ticks]) has 'PlaceRuntime' placement. + + - PlaceNonLam: source notes. + + Like PlaceRuntime, but we can also float the tick through value lambdas: + + tick <t> (\x. e) ==> \x. tick <t> e + + This makes sense where there is little difference between annotating the + lambda and annotating the lambda's code. + + - PlaceCostCentre: non-counting profiling ticks. + + In addition to floating through lambdas, cost-centre style tickishs can be + pushed into (saturated) constructor applications, and can be eliminated when + placed around non-function variables: + + tick <t> (C e1 e2) ==> C (tick <t> e1) (tick <t> e2) + + tick <t> (x :: Int) ==> (x :: Int) + + Neither the constructor application nor the variable 'x' are likely to have + any cost worth mentioning. + +We generally try to push ticks inwards until they end up placed around a Core +expression that is appropriate for their placement rule, as described above. +This gives us the opportunity to eliminate the tick, either by combining it with +another tick (see 'combineTickish_maybe') or by dropping it altogether. For +example, a (non-counting) SCC around a non-function variable can be dropped, as +there is no cost to scope over. + +After the tick has been placed by 'mkTick', the simplifier may later (during +simplification) decide to float it outwards (see e.g. GHC.Core.Opt.Simplify.Iteration.simplTick). +The story here is not fully worked out, as the simplifier calls 'mkTick', which +might push the tick inwards again. -} -- | Returns @True@ for ticks that can be floated upwards easily even @@ -441,35 +501,19 @@ isProfTick _ = False -- annotating for example using @mkTick@. If we find that we want to -- put a tickish on an expression ruled out here, we try to float it -- inwards until we find a suitable expression. +-- +-- See Note [Tickish placement]. data TickishPlacement = - -- | Place ticks exactly on run-time expressions. We can still - -- move the tick through pure compile-time constructs such as - -- other ticks, casts or type lambdas. This is the most - -- restrictive placement rule for ticks, as all tickishs have in - -- common that they want to track runtime processes. The only - -- legal placement rule for counting ticks. - -- NB: We generally try to move these as close to the relevant - -- runtime expression as possible. This means they get pushed through - -- tyoe arguments. E.g. we create `(tick f) @Bool` instead of `tick (f @Bool)`. + -- | Place ticks exactly on run-time expressions, moving them through pure + -- compile-time constructs such as other ticks, casts or type lambdas. PlaceRuntime - -- | As @PlaceRuntime@, but we float the tick through all - -- lambdas. This makes sense where there is little difference - -- between annotating the lambda and annotating the lambda's code. + -- | As @PlaceRuntime@, but also allow to float the tick through all lambdas. | PlaceNonLam - -- | In addition to floating through lambdas, cost-centre style - -- tickishs can also be moved from constructors, non-function - -- variables and literals. For example: - -- - -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ... - -- - -- Neither the constructor application, the variable or the - -- literal are likely to have any cost worth mentioning. And even - -- if y names a thunk, the call would not care about the - -- evaluation context. Therefore removing all annotations in the - -- above example is safe. + -- | As 'PlaceNonLam', but also float through constructors, non-function + -- variables and literals. | PlaceCostCentre deriving (Eq,Show) @@ -477,7 +521,9 @@ data TickishPlacement = instance Outputable TickishPlacement where ppr = text . show --- | Placement behaviour we want for the ticks +-- | Placement behaviour we want for the ticks. +-- +-- See Note [Tickish placement]. tickishPlace :: GenTickish pass -> TickishPlacement tickishPlace n@ProfNote{} | profNoteCount n = PlaceRuntime @@ -486,6 +532,43 @@ tickishPlace HpcTick{} = PlaceRuntime tickishPlace Breakpoint{} = PlaceRuntime tickishPlace SourceNote{} = PlaceNonLam +-- | Merge two ticks into one, if that is possible. +-- +-- Examples: +-- +-- - combine two source note ticks if one contains the other, +-- - combine a non-counting profiling tick with a non-scoping profiling tick +-- for the same cost centre +-- - combine two equal breakpoint ticks or HPC ticks +combineTickish_maybe :: Eq (GenTickish pass) + => GenTickish pass -> GenTickish pass -> Maybe (GenTickish pass) +combineTickish_maybe + (ProfNote { profNoteCC = cc1, profNoteCount = cnt1, profNoteScope = scope1 }) + (ProfNote { profNoteCC = cc2, profNoteCount = cnt2, profNoteScope = scope2 }) + | cc1 == cc2 + , not cnt1 || not cnt2 + = Just $ ProfNote { profNoteCC = cc1 + , profNoteCount = cnt1 || cnt2 + , profNoteScope = scope1 || scope2 + } +combineTickish_maybe t1@(SourceNote sp1 n1) t2@(SourceNote sp2 n2) + | n1 == n2 + , sp1 `containsSpan` sp2 + = Just t1 + | n1 == n2 + , sp2 `containsSpan` sp1 + = Just t2 + -- NB: it would be possible to use 'combineRealSrcSpans' instead, + -- but that has the risk of combining many source note ticks into a single + -- tick with a huge source span. +combineTickish_maybe t1@(HpcTick {}) t2@(HpcTick {}) + | t1 == t2 + = Just t1 +combineTickish_maybe t1@(Breakpoint {}) t2@(Breakpoint {}) + | t1 == t2 + = Just t1 +combineTickish_maybe _ _ = Nothing + -- | Returns whether one tick "contains" the other one, therefore -- making the second tick redundant. tickishContains :: Eq (GenTickish pass) ===================================== libraries/ghc-heap/tests/tso_and_stack_closures.hs ===================================== @@ -48,7 +48,9 @@ main = do assertEqual (cc_module myCostCentre) "Main" assertEqual (cc_srcloc myCostCentre) (Just "tso_and_stack_closures.hs:24:48-80") assertEqual (cc_is_caf myCostCentre) False - Nothing -> error $ "MyCostCentre not found in:\n" ++ unlines (cc_label <$> linkedCostCentres costCentre) + Nothing -> error "MyCostCentre not found" + -- Don't print all of 'linkedCostCentres costCentre', + -- as that is ~20k lines of output. #endif linkedCostCentres :: Maybe CostCentre -> [CostCentre] ===================================== testsuite/tests/profiling/should_compile/T27121.hs ===================================== @@ -0,0 +1,12 @@ +module T27121 where + +import T27121_aux + +updateFileDiagnostics + :: LanguageContextEnv () + -> IO () +updateFileDiagnostics env = do + withTrace $ \ _tag -> + runLspT env $ do + sendNotification SMethod_TextDocumentPublishDiagnostics + PublishDiagnosticsParams ===================================== testsuite/tests/profiling/should_compile/T27121_aux.hs ===================================== @@ -0,0 +1,354 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} + +module T27121_aux + ( withTrace + , sendNotification + , LspT, runLspT + , SMethod(..) + , LanguageContextEnv + , PublishDiagnosticsParams(..) + ) + where + +-- base +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Data.Kind ( Type ) +import GHC.TypeLits ( Symbol ) + +-------------------------------------------------------------------------------- + +withTrace :: Monad m => ((String -> String -> m ()) -> m a) -> m a +withTrace act + | myUserTracingEnabled + = return undefined + | otherwise = act (\_ _ -> pure ()) +{-# NOINLINE withTrace #-} + +myUserTracingEnabled :: Bool +myUserTracingEnabled = False +{-# NOINLINE myUserTracingEnabled #-} + +type Text = String + +newtype LspT config a = LspT {unLspT :: LanguageContextEnv config -> IO a} + +instance Functor (LspT config) where + fmap f (LspT g) = LspT (fmap f . g) + +instance Applicative (LspT config) where + pure = LspT . const . pure + LspT f <*> LspT a = LspT $ \ env -> f env <*> a env +instance Monad (LspT config) where + LspT a >>= f = LspT $ \ env -> do + b <- a env + unLspT ( f b ) env +instance MonadIO (LspT config) where + liftIO = LspT . const . liftIO + +type role LspT representational nominal + +runLspT :: LanguageContextEnv config -> LspT config a -> IO a +runLspT env (LspT f) = f env +{-# INLINE runLspT #-} + +data PublishDiagnosticsParams = PublishDiagnosticsParams + +data LanguageContextEnv config = + LanguageContextEnv + { resSendMessage :: FromServerMessage -> IO () } + + +sendNotification :: + forall (m :: Method ServerToClient Notification) f config. + MonadLsp config f => + SServerMethod m -> + MessageParams m -> + f () +sendNotification m params = + let msg = TNotificationMessage { _method = m, _params = params } + in case splitServerMethod m of + IsServerNot -> sendToClient $ fromServerNot msg + +type Method :: MessageDirection -> MessageKind -> Type +data Method f t where + Method_TextDocumentImplementation :: Method ClientToServer Request + Method_TextDocumentTypeDefinition :: Method ClientToServer Request + Method_WorkspaceWorkspaceFolders :: Method ServerToClient Request + Method_WorkspaceConfiguration :: Method ServerToClient Request + Method_TextDocumentDocumentColor :: Method ClientToServer Request + Method_TextDocumentColorPresentation :: Method ClientToServer Request + Method_TextDocumentFoldingRange :: Method ClientToServer Request + Method_TextDocumentDeclaration :: Method ClientToServer Request + Method_TextDocumentSelectionRange :: Method ClientToServer Request + Method_WindowWorkDoneProgressCreate :: Method ServerToClient Request + Method_TextDocumentPrepareCallHierarchy :: Method ClientToServer Request + Method_CallHierarchyIncomingCalls :: Method ClientToServer Request + Method_CallHierarchyOutgoingCalls :: Method ClientToServer Request + Method_TextDocumentSemanticTokensFull :: Method ClientToServer Request + Method_TextDocumentSemanticTokensFullDelta :: Method ClientToServer Request + Method_TextDocumentSemanticTokensRange :: Method ClientToServer Request + Method_WorkspaceSemanticTokensRefresh :: Method ServerToClient Request + Method_WindowShowDocument :: Method ServerToClient Request + Method_TextDocumentLinkedEditingRange :: Method ClientToServer Request + Method_WorkspaceWillCreateFiles :: Method ClientToServer Request + Method_WorkspaceWillRenameFiles :: Method ClientToServer Request + Method_WorkspaceWillDeleteFiles :: Method ClientToServer Request + Method_TextDocumentMoniker :: Method ClientToServer Request + Method_TextDocumentPrepareTypeHierarchy :: Method ClientToServer Request + Method_TypeHierarchySupertypes :: Method ClientToServer Request + Method_TypeHierarchySubtypes :: Method ClientToServer Request + Method_TextDocumentInlineValue :: Method ClientToServer Request + Method_WorkspaceInlineValueRefresh :: Method ServerToClient Request + Method_TextDocumentInlayHint :: Method ClientToServer Request + Method_InlayHintResolve :: Method ClientToServer Request + Method_WorkspaceInlayHintRefresh :: Method ServerToClient Request + Method_TextDocumentDiagnostic :: Method ClientToServer Request + Method_WorkspaceDiagnostic :: Method ClientToServer Request + Method_WorkspaceDiagnosticRefresh :: Method ServerToClient Request + Method_ClientRegisterCapability :: Method ServerToClient Request + Method_ClientUnregisterCapability :: Method ServerToClient Request + Method_Initialize :: Method ClientToServer Request + Method_Shutdown :: Method ClientToServer Request + Method_WindowShowMessageRequest :: Method ServerToClient Request + Method_TextDocumentWillSaveWaitUntil :: Method ClientToServer Request + Method_TextDocumentCompletion :: Method ClientToServer Request + Method_CompletionItemResolve :: Method ClientToServer Request + Method_TextDocumentHover :: Method ClientToServer Request + Method_TextDocumentSignatureHelp :: Method ClientToServer Request + Method_TextDocumentDefinition :: Method ClientToServer Request + Method_TextDocumentReferences :: Method ClientToServer Request + Method_TextDocumentDocumentHighlight :: Method ClientToServer Request + Method_TextDocumentDocumentSymbol :: Method ClientToServer Request + Method_TextDocumentCodeAction :: Method ClientToServer Request + Method_CodeActionResolve :: Method ClientToServer Request + Method_WorkspaceSymbol :: Method ClientToServer Request + Method_WorkspaceSymbolResolve :: Method ClientToServer Request + Method_TextDocumentCodeLens :: Method ClientToServer Request + Method_CodeLensResolve :: Method ClientToServer Request + Method_WorkspaceCodeLensRefresh :: Method ServerToClient Request + Method_TextDocumentDocumentLink :: Method ClientToServer Request + Method_DocumentLinkResolve :: Method ClientToServer Request + Method_TextDocumentFormatting :: Method ClientToServer Request + Method_TextDocumentRangeFormatting :: Method ClientToServer Request + Method_TextDocumentOnTypeFormatting :: Method ClientToServer Request + Method_TextDocumentRename :: Method ClientToServer Request + Method_TextDocumentPrepareRename :: Method ClientToServer Request + Method_WorkspaceExecuteCommand :: Method ClientToServer Request + Method_WorkspaceApplyEdit :: Method ServerToClient Request + Method_WorkspaceDidChangeWorkspaceFolders :: Method ClientToServer Notification + Method_WindowWorkDoneProgressCancel :: Method ClientToServer Notification + Method_WorkspaceDidCreateFiles :: Method ClientToServer Notification + Method_WorkspaceDidRenameFiles :: Method ClientToServer Notification + Method_WorkspaceDidDeleteFiles :: Method ClientToServer Notification + Method_NotebookDocumentDidOpen :: Method ClientToServer Notification + Method_NotebookDocumentDidChange :: Method ClientToServer Notification + Method_NotebookDocumentDidSave :: Method ClientToServer Notification + Method_NotebookDocumentDidClose :: Method ClientToServer Notification + Method_Initialized :: Method ClientToServer Notification + Method_Exit :: Method ClientToServer Notification + Method_WorkspaceDidChangeConfiguration :: Method ClientToServer Notification + Method_WindowShowMessage :: Method ServerToClient Notification + Method_WindowLogMessage :: Method ServerToClient Notification + Method_TelemetryEvent :: Method ServerToClient Notification + Method_TextDocumentDidOpen :: Method ClientToServer Notification + Method_TextDocumentDidChange :: Method ClientToServer Notification + Method_TextDocumentDidClose :: Method ClientToServer Notification + Method_TextDocumentDidSave :: Method ClientToServer Notification + Method_TextDocumentWillSave :: Method ClientToServer Notification + Method_WorkspaceDidChangeWatchedFiles :: Method ClientToServer Notification + Method_TextDocumentPublishDiagnostics :: Method ServerToClient Notification + Method_SetTrace :: Method ClientToServer Notification + Method_LogTrace :: Method ServerToClient Notification + Method_CancelRequest :: Method f Notification + Method_Progress :: Method f Notification + Method_CustomMethod :: Symbol -> Method f t + +type SMethod :: forall f t . Method f t -> Type +data SMethod m where + SMethod_TextDocumentImplementation :: SMethod Method_TextDocumentImplementation + SMethod_TextDocumentTypeDefinition :: SMethod Method_TextDocumentTypeDefinition + SMethod_WorkspaceWorkspaceFolders :: SMethod Method_WorkspaceWorkspaceFolders + SMethod_WorkspaceConfiguration :: SMethod Method_WorkspaceConfiguration + SMethod_TextDocumentDocumentColor :: SMethod Method_TextDocumentDocumentColor + SMethod_TextDocumentColorPresentation :: SMethod Method_TextDocumentColorPresentation + SMethod_TextDocumentFoldingRange :: SMethod Method_TextDocumentFoldingRange + SMethod_TextDocumentDeclaration :: SMethod Method_TextDocumentDeclaration + SMethod_TextDocumentSelectionRange :: SMethod Method_TextDocumentSelectionRange + SMethod_WindowWorkDoneProgressCreate :: SMethod Method_WindowWorkDoneProgressCreate + SMethod_TextDocumentPrepareCallHierarchy :: SMethod Method_TextDocumentPrepareCallHierarchy + SMethod_CallHierarchyIncomingCalls :: SMethod Method_CallHierarchyIncomingCalls + SMethod_CallHierarchyOutgoingCalls :: SMethod Method_CallHierarchyOutgoingCalls + SMethod_TextDocumentSemanticTokensFull :: SMethod Method_TextDocumentSemanticTokensFull + SMethod_TextDocumentSemanticTokensFullDelta :: SMethod Method_TextDocumentSemanticTokensFullDelta + SMethod_TextDocumentSemanticTokensRange :: SMethod Method_TextDocumentSemanticTokensRange + SMethod_WorkspaceSemanticTokensRefresh :: SMethod Method_WorkspaceSemanticTokensRefresh + SMethod_WindowShowDocument :: SMethod Method_WindowShowDocument + SMethod_TextDocumentLinkedEditingRange :: SMethod Method_TextDocumentLinkedEditingRange + SMethod_WorkspaceWillCreateFiles :: SMethod Method_WorkspaceWillCreateFiles + SMethod_WorkspaceWillRenameFiles :: SMethod Method_WorkspaceWillRenameFiles + SMethod_WorkspaceWillDeleteFiles :: SMethod Method_WorkspaceWillDeleteFiles + SMethod_TextDocumentMoniker :: SMethod Method_TextDocumentMoniker + SMethod_TextDocumentPrepareTypeHierarchy :: SMethod Method_TextDocumentPrepareTypeHierarchy + SMethod_TypeHierarchySupertypes :: SMethod Method_TypeHierarchySupertypes + SMethod_TypeHierarchySubtypes :: SMethod Method_TypeHierarchySubtypes + SMethod_TextDocumentInlineValue :: SMethod Method_TextDocumentInlineValue + SMethod_WorkspaceInlineValueRefresh :: SMethod Method_WorkspaceInlineValueRefresh + SMethod_TextDocumentInlayHint :: SMethod Method_TextDocumentInlayHint + SMethod_InlayHintResolve :: SMethod Method_InlayHintResolve + SMethod_WorkspaceInlayHintRefresh :: SMethod Method_WorkspaceInlayHintRefresh + SMethod_TextDocumentDiagnostic :: SMethod Method_TextDocumentDiagnostic + SMethod_WorkspaceDiagnostic :: SMethod Method_WorkspaceDiagnostic + SMethod_WorkspaceDiagnosticRefresh :: SMethod Method_WorkspaceDiagnosticRefresh + SMethod_ClientRegisterCapability :: SMethod Method_ClientRegisterCapability + SMethod_ClientUnregisterCapability :: SMethod Method_ClientUnregisterCapability + SMethod_Initialize :: SMethod Method_Initialize + SMethod_Shutdown :: SMethod Method_Shutdown + SMethod_WindowShowMessageRequest :: SMethod Method_WindowShowMessageRequest + SMethod_TextDocumentWillSaveWaitUntil :: SMethod Method_TextDocumentWillSaveWaitUntil + SMethod_TextDocumentCompletion :: SMethod Method_TextDocumentCompletion + SMethod_CompletionItemResolve :: SMethod Method_CompletionItemResolve + SMethod_TextDocumentHover :: SMethod Method_TextDocumentHover + SMethod_TextDocumentSignatureHelp :: SMethod Method_TextDocumentSignatureHelp + SMethod_TextDocumentDefinition :: SMethod Method_TextDocumentDefinition + SMethod_TextDocumentReferences :: SMethod Method_TextDocumentReferences + SMethod_TextDocumentDocumentHighlight :: SMethod Method_TextDocumentDocumentHighlight + SMethod_TextDocumentDocumentSymbol :: SMethod Method_TextDocumentDocumentSymbol + SMethod_TextDocumentCodeAction :: SMethod Method_TextDocumentCodeAction + SMethod_CodeActionResolve :: SMethod Method_CodeActionResolve + SMethod_WorkspaceSymbol :: SMethod Method_WorkspaceSymbol + SMethod_WorkspaceSymbolResolve :: SMethod Method_WorkspaceSymbolResolve + SMethod_TextDocumentCodeLens :: SMethod Method_TextDocumentCodeLens + SMethod_CodeLensResolve :: SMethod Method_CodeLensResolve + SMethod_WorkspaceCodeLensRefresh :: SMethod Method_WorkspaceCodeLensRefresh + SMethod_TextDocumentDocumentLink :: SMethod Method_TextDocumentDocumentLink + SMethod_DocumentLinkResolve :: SMethod Method_DocumentLinkResolve + SMethod_TextDocumentFormatting :: SMethod Method_TextDocumentFormatting + SMethod_TextDocumentRangeFormatting :: SMethod Method_TextDocumentRangeFormatting + SMethod_TextDocumentOnTypeFormatting :: SMethod Method_TextDocumentOnTypeFormatting + SMethod_TextDocumentRename :: SMethod Method_TextDocumentRename + SMethod_TextDocumentPrepareRename :: SMethod Method_TextDocumentPrepareRename + SMethod_WorkspaceExecuteCommand :: SMethod Method_WorkspaceExecuteCommand + SMethod_WorkspaceApplyEdit :: SMethod Method_WorkspaceApplyEdit + SMethod_WorkspaceDidChangeWorkspaceFolders :: SMethod Method_WorkspaceDidChangeWorkspaceFolders + SMethod_WindowWorkDoneProgressCancel :: SMethod Method_WindowWorkDoneProgressCancel + SMethod_WorkspaceDidCreateFiles :: SMethod Method_WorkspaceDidCreateFiles + SMethod_WorkspaceDidRenameFiles :: SMethod Method_WorkspaceDidRenameFiles + SMethod_WorkspaceDidDeleteFiles :: SMethod Method_WorkspaceDidDeleteFiles + SMethod_NotebookDocumentDidOpen :: SMethod Method_NotebookDocumentDidOpen + SMethod_NotebookDocumentDidChange :: SMethod Method_NotebookDocumentDidChange + SMethod_NotebookDocumentDidSave :: SMethod Method_NotebookDocumentDidSave + SMethod_NotebookDocumentDidClose :: SMethod Method_NotebookDocumentDidClose + SMethod_Initialized :: SMethod Method_Initialized + SMethod_Exit :: SMethod Method_Exit + SMethod_WorkspaceDidChangeConfiguration :: SMethod Method_WorkspaceDidChangeConfiguration + SMethod_WindowShowMessage :: SMethod Method_WindowShowMessage + SMethod_WindowLogMessage :: SMethod Method_WindowLogMessage + SMethod_TelemetryEvent :: SMethod Method_TelemetryEvent + SMethod_TextDocumentDidOpen :: SMethod Method_TextDocumentDidOpen + SMethod_TextDocumentDidChange :: SMethod Method_TextDocumentDidChange + SMethod_TextDocumentDidClose :: SMethod Method_TextDocumentDidClose + SMethod_TextDocumentDidSave :: SMethod Method_TextDocumentDidSave + SMethod_TextDocumentWillSave :: SMethod Method_TextDocumentWillSave + SMethod_WorkspaceDidChangeWatchedFiles :: SMethod Method_WorkspaceDidChangeWatchedFiles + SMethod_TextDocumentPublishDiagnostics :: SMethod Method_TextDocumentPublishDiagnostics + SMethod_SetTrace :: SMethod Method_SetTrace + SMethod_LogTrace :: SMethod Method_LogTrace + SMethod_CancelRequest :: SMethod Method_CancelRequest + SMethod_Progress :: SMethod Method_Progress + +type SServerMethod (m :: Method ServerToClient t) = SMethod m + +data MessageDirection = ServerToClient | ClientToServer + +data MessageKind = Notification | Request + + +type ServerNotOrReq :: forall t. Method ServerToClient t -> Type +data ServerNotOrReq m where + IsServerNot :: + ( TMessage m ~ TNotificationMessage m + ) => + ServerNotOrReq (m :: Method ServerToClient Notification) + IsServerReq :: + forall (m :: Method ServerToClient Request). + ( TMessage m ~ TRequestMessage m + ) => + ServerNotOrReq m + +type TMessage :: forall f t. Method f t -> Type +type family TMessage m where + TMessage (Method_CustomMethod s :: Method f t) = () + TMessage (m :: Method f Request) = TRequestMessage m + TMessage (m :: Method f Notification) = TNotificationMessage m + + +data TNotificationMessage (m :: Method f Notification) = TNotificationMessage + { _method :: SMethod m + , _params :: MessageParams m + } + +data TRequestMessage (m :: Method f Request) = TRequestMessage + +type MessageParams :: forall f t . Method f t -> Type +type family MessageParams (m :: Method f t) where + MessageParams Method_TextDocumentPublishDiagnostics = PublishDiagnosticsParams + +class MonadIO m => MonadLsp config m | m -> config where + getLspEnv :: m (LanguageContextEnv config) + +instance MonadLsp config (LspT config) where + {-# INLINE getLspEnv #-} + getLspEnv = LspT pure + + +{-# INLINE splitServerMethod #-} +splitServerMethod :: SServerMethod m -> ServerNotOrReq m +splitServerMethod = \case + SMethod_TextDocumentPublishDiagnostics -> IsServerNot + SMethod_WindowShowMessage -> IsServerNot + SMethod_WindowShowMessageRequest -> IsServerReq + SMethod_WindowShowDocument -> IsServerReq + SMethod_WindowLogMessage -> IsServerNot + SMethod_WindowWorkDoneProgressCreate -> IsServerReq + SMethod_Progress -> IsServerNot + SMethod_TelemetryEvent -> IsServerNot + SMethod_ClientRegisterCapability -> IsServerReq + SMethod_ClientUnregisterCapability -> IsServerReq + SMethod_WorkspaceWorkspaceFolders -> IsServerReq + SMethod_WorkspaceConfiguration -> IsServerReq + SMethod_WorkspaceApplyEdit -> IsServerReq + SMethod_LogTrace -> IsServerNot + SMethod_CancelRequest -> IsServerNot + SMethod_WorkspaceCodeLensRefresh -> IsServerReq + SMethod_WorkspaceSemanticTokensRefresh -> IsServerReq + SMethod_WorkspaceInlineValueRefresh -> IsServerReq + SMethod_WorkspaceInlayHintRefresh -> IsServerReq + SMethod_WorkspaceDiagnosticRefresh -> IsServerReq + +fromServerNot :: + forall (m :: Method ServerToClient Notification). + TMessage m ~ TNotificationMessage m => + TNotificationMessage m -> + FromServerMessage +fromServerNot m@TNotificationMessage{_method = meth} = FromServerMess meth m + + +data FromServerMessage' a where + FromServerMess :: forall t (m :: Method ServerToClient t) a. SMethod m -> TMessage m -> FromServerMessage' a + FromServerRsp :: forall (m :: Method ClientToServer Request) a. a m -> TResponseMessage m -> FromServerMessage' a + +type FromServerMessage = FromServerMessage' SMethod + +data TResponseMessage (m :: Method f Request) = TResponseMessage + +sendToClient :: MonadLsp config m => FromServerMessage -> m () +sendToClient msg = do + f <- resSendMessage <$> getLspEnv + liftIO $ f msg +{-# INLINE sendToClient #-} ===================================== testsuite/tests/profiling/should_compile/all.T ===================================== @@ -21,3 +21,4 @@ test('T15108', [test_opts], compile, ['-O -prof -fprof-auto']) test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894']) test('T20938', [test_opts], compile, ['-O -prof']) test('T26056', [test_opts], compile, ['-O -prof']) +test('T27121', [test_opts, extra_files(['T27121_aux.hs'])], compile, ['-O -prof -fprof-auto']) ===================================== testsuite/tests/simplCore/should_compile/T26941.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +module T26941 where + +import GHC.TypeLits + +import T26941_aux ( SMayNat(SKnown), ListH, shxHead ) + +shsHead :: ListH (Just n : sh) Int -> SNat n +shsHead shx = + case shxHead shx of + SKnown SNat -> SNat ===================================== testsuite/tests/simplCore/should_compile/T26941_aux.hs ===================================== @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module T26941_aux where + +import Data.Kind +import GHC.TypeLits + +shxHead :: ListH (n : sh) i -> SMayNat i n +shxHead list = {-# SCC "bad_scc" #-} + ( case list of (i `ConsKnown` _) -> SKnown i ) + +type ListH :: [Maybe Nat] -> Type -> Type +data ListH sh i where + ConsKnown :: SNat n -> ListH sh i -> ListH (Just n : sh) i + +data SMayNat i n where + SKnown :: SNat n -> SMayNat i (Just n) ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -576,6 +576,8 @@ test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniqu test('T26349', normal, compile, ['-O -ddump-rules']) test('T26681', normal, compile, ['-O']) +test('T26941', [extra_files(['T26941_aux.hs']), req_profiling], multimod_compile, ['T26941', '-v0 -O -prof']) + # T26709: we expect three `case` expressions not four test('T26709', [grep_errmsg(r'case')], multimod_compile, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df3a4143a73efabd36377c635b16f33… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df3a4143a73efabd36377c635b16f33… You're receiving this email because of your account on gitlab.haskell.org.

1 0