sheaf pushed to branch wip/T26878 at Glasgow Haskell Compiler / GHC
Commits:
094aa186 by sheaf at 2026-04-07T15:55:21+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>
- - - - -
10 changed files:
- compiler/GHC/Core/Opt/FloatOut.hs
- 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/Opt/FloatOut.hs
=====================================
@@ -383,10 +383,37 @@ floatExpr (Tick tickish expr)
case (floatExpr expr) of { (fs, floating_defns, expr') ->
-- Wrap floated code with the correct tick scope, but using 'mkNoCount'
-- to ensure we don't duplicate counters.
+ --
+ -- See also Note [Avoiding duplicate ticks].
let annotated_defns = wrapTick (mkNoCount tickish) floating_defns
in
(fs, annotated_defns, Tick tickish expr') }
+{- Note [Avoiding duplicate ticks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When FloatOut floats an expression through scoped ticks, it accumulates all
+the scopes on the way, e.g.
+
+ src<loc1>
+ let x = ..
+ in
+ src<loc2>
+ let y = ...
+ in
+ src<loc3>
+ let z = fib 100
+ in ...
+
+When we float 'z' out to the top level, it will accumulate all the intervening
+ticks:
+
+ lvl_z = src<loc1> src<loc2> src<loc3> fib 100
+
+It's important to combine these ticks up as much as possible to avoid hugely
+bloating the Core; for example if loc1 = loc3 then we should combine those two
+source notes, which requires moving src<loc1> past src<loc2> to allow
+cancellation to take place.
+-}
floatExpr (Cast expr co)
= case (floatExpr expr) of { (fs, floating_defns, expr') ->
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -303,101 +303,276 @@ 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
-
- -- 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)]
+ -- See Note [Scoping ticks and counting ticks] in GHC.Types.Tickish.
+ can_split = tickishCanSplit t
+
+ -- Can we commute these two ticks?
+ commutable :: CoreTickish -> CoreTickish -> Bool
+ -- Profiling ticks for different cost centres should never be reordered
+ -- relative to each other.
+ commutable (ProfNote { profNoteCC = cc1 }) (ProfNote { profNoteCC = cc2 })
+ = cc1 == cc2
+
+ -- 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.
+ commutable t1 t2
+ | tickishPlace t1 /= tickishPlace t2
+ = True
- -- Cost centre ticks should never be reordered relative to each
- -- other. Therefore we can stop whenever two collide.
+ -- Source notes can be moved past all other ticks, in order to expose
+ -- cancellation opportunities, e.g. 'src<loc1> src<loc2> src<loc1>'.
+ -- This is crucially important for FloatOut: see
+ -- Note [Avoiding duplicate ticks] in GHC.Core.Opt.FloatOut.
+ commutable (SourceNote {}) _ = True
+ commutable _ (SourceNote {}) = True
+ commutable _ _ = False
+
+ -- 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
+
+ -- Re-order the ticks if possible, in an attempt to eliminate tick 't'.
+ | commutable t t2
+ -> 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 +2720,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
@@ -140,20 +141,7 @@ data GenTickish pass =
-- | A source note.
--
- -- Source notes are pure annotations: Their presence should neither
- -- influence compilation nor execution. The semantics are given by
- -- causality: The presence of a source note means that a local
- -- change in the referenced source code span will possibly provoke
- -- the generated code to change. On the flip-side, the functionality
- -- of annotated code *must* be invariant against changes to all
- -- source code *except* the spans referenced in the source notes
- -- (see "Causality of optimized Haskell" paper for details).
- --
- -- Therefore extending the scope of any given source note is always
- -- valid. Note that it is still undesirable though, as this reduces
- -- their usefulness for debugging and profiling. Therefore we will
- -- generally try only to make use of this property where it is
- -- necessary to enable optimizations.
+ -- See Note [Source notes and debug information]
| SourceNote
{ sourceSpan :: RealSrcSpan -- ^ Source covered
, sourceName :: LexicalFastString -- ^ Name for source location
@@ -170,6 +158,45 @@ deriving instance Eq (GenTickish 'TickishPassCmm)
deriving instance Ord (GenTickish 'TickishPassCmm)
deriving instance Data (GenTickish 'TickishPassCmm)
+{- Note [Source notes and debug information]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Source notes are used to generate debug information, in the form of DWARF
+directives in the generated assembly:
+
+ # At the top of the assembly file
+
+ .file 1 "MyModule.hs"
+ .file 2 "OtherModule.hs"
+
+ ...
+
+ # Generated assembly for a particular piece of code
+
+ # - The DWARF debug information
+ # This is not an instruction; it's information for the debugger.
+ .loc 1 1287 8 # MyModule.hs, line 1287, column 8
+
+ # - The actual assembly instructions
+ movq 16(%rbx), %rax
+ addq $1, %rax
+ movq %rax, 16(%rbx)
+
+Source notes are enabled by passing the -g flag to GHC.
+
+Source notes are pure annotations: their presence should neither influence
+compilation nor execution.
+The semantics are given by causality: the presence of a source note means that
+a local change in the referenced source code span will possibly provoke the
+generated code to change.
+On the flip-side, the functionality of annotated code *must* be invariant
+against changes to all source code *except* the spans referenced in the source
+notes (see "Causality of optimized Haskell" paper for details).
+This means that it is valid to extend the scope of any given source note, but
+it is undesirable as this reduces its usefulness for debugging and profiling.
+Therefore, we will generally try only to make use of this property where it is
+necessary to enable optimizations.
+-}
+
--------------------------------------------------------------------------------
-- Tick breakpoint index
--------------------------------------------------------------------------------
@@ -261,8 +288,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 +321,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 +406,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 +527,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 +547,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 +558,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', '-v0 -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/094aa1868ac7e374a4f3dc7a165decc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/094aa1868ac7e374a4f3dc7a165decc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/26435] 19 commits: Streamline expansions using HsExpansion (#25001)
by Zubin (＠wz1000) 07 Apr '26
by Zubin (＠wz1000) 07 Apr '26
07 Apr '26
Zubin pushed to branch wip/26435 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>
- - - - -
bc4b4487 by Zubin Duggal at 2026-04-03T14:22:27-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
- - - - -
5ebb9121 by Simon Jakobi at 2026-04-03T14:23:11-04:00
Add regression test for #16145
Closes #16145.
- - - - -
c1fc1c44 by Simon Peyton Jones at 2026-04-03T19:56:07-04:00
Refactor eta-expansion in Prep
The Prep pass does eta-expansion but I found cases where it was
doing bad things. So I refactored and simplified it quite a bit.
In the new design
* There is no distinction between `rhs` and `body`; in particular,
lambdas can now appear anywhere, rather than just as the RHS of
a let-binding.
* This change led to a significant simplification of Prep, and
a more straightforward explanation of eta-expansion. See the new
Note [Eta expansion]
* The consequences is that CoreToStg needs to handle naked lambdas.
This is very easy; but it does need a unique supply, which forces
some simple refactoring. Having a unique supply to hand is probably
a good thing anyway.
- - - - -
21beda2c by Simon Peyton Jones at 2026-04-03T19:56:07-04:00
Clarify Note [Interesting dictionary arguments]
Ticket #26831 ended up concluding that the code for
GHC.Core.Opt.Specialise.interestingDict was good, but the
commments were a bit inadequate.
This commit improves the comments slightly.
- - - - -
3eaac1f2 by Simon Peyton Jones at 2026-04-03T19:56:07-04:00
Make inlining a bit more eager for overloaded functions
If we have
f d = ... (class-op d x y) ...
we should be eager to inline `f`, because that may change the
higher order call (class-op d x y) into a call to a statically
known function.
See the discussion on #26831.
Even though this does a bit /more/ inlining, compile times
decrease by an average of 0.4%.
Compile time changes:
DsIncompleteRecSel3(normal) 431,786,104 -2.2%
ManyAlternatives(normal) 670,883,768 -1.6%
ManyConstructors(normal) 3,758,493,832 -2.6% GOOD
MultilineStringsPerf(normal) 29,900,576 -2.8%
T14052Type(ghci) 1,047,600,848 -1.2%
T17836(normal) 392,852,328 -5.2%
T18478(normal) 442,785,768 -1.4%
T21839c(normal) 341,536,992 -14.1% GOOD
T3064(normal) 174,086,152 +5.3% BAD
T5631(normal) 506,867,800 +1.0%
hard_hole_fits(normal) 209,530,736 -1.3%
info_table_map_perf(normal) 19,523,093,184 -1.2%
parsing001(normal) 377,810,528 -1.1%
pmcOrPats(normal) 60,075,264 -0.5%
geo. mean -0.4%
minimum -14.1%
maximum +5.3%
Runtime changes
haddock.Cabal(normal) 27,351,988,792 -0.7%
haddock.base(normal) 26,997,212,560 -0.6%
haddock.compiler(normal) 219,531,332,960 -1.0%
Metric Decrease:
LinkableUsage01
ManyConstructors
T17949
T21839c
T13035
TcPlugin_RewritePerf
hard_hole_fits
Metric Increase:
T3064
- - - - -
5cbc2c82 by Matthew Pickering at 2026-04-03T19:57:02-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
- - - - -
d95a1936 by fendor at 2026-04-03T19:57:02-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.
- - - - -
b822c30a by mangoiv at 2026-04-03T19:57:49-04:00
testsuite: filter stderr for static001 on darwin
This reactivates the test on x86_64 darwin as this should have been done
long ago and ignores warnings emitted by ranlib on newer version of the
darwin toolchain since they are benign. (no symbols for stub libraries)
Fixes #27116
- - - - -
28ce1f8a by Andreas Klebinger at 2026-04-03T19:58:44-04:00
Give the Data instance for ModuleName a non-bottom toConstr implementation.
I've also taken the liberty to add Note [Data.Data instances for GHC AST Types]
describing some of the uses of Data.Data I could find.
Fixes #27129
- - - - -
8ca41ffe by mangoiv at 2026-04-03T19:59:30-04:00
issue template: fix add bug label
- - - - -
3981db0c by Sylvain Henry at 2026-04-03T20:00:33-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>
- - - - -
d17d1435 by Matthew Pickering at 2026-04-03T20:01:19-04:00
Make home unit dependencies stored as sets
Co-authored-by: Wolfgang Jeltsch <wolfgang(a)well-typed.com>
- - - - -
92a97015 by Simon Peyton Jones at 2026-04-05T00:58:57+01:00
Add Invariant (NoTypeShadowing) to Core
This commit addresses #26868, by adding
a new invariant (NoTypeShadowing) to Core.
See Note [No type-shadowing in Core] in GHC.Core
- - - - -
8b5a5020 by Simon Peyton Jones at 2026-04-05T00:58: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.
- - - - -
4bf040c6 by sheaf at 2026-04-05T14:56:29-04:00
Add utility pprTrace_ function
This function is useful for quick debugging, as it can be added to a
where clause to pretty-print debugging information:
fooBar x y
| cond = body1
| otherwise = body2
where
!_ = pprTrace_ "fooBar" $
vcat [ text "x:" <+> ppr x
, text "y:" <+> ppr y
, text "cond:" <+> ppr cond
]
- - - - -
502e6ffe by Andrew Lelechenko at 2026-04-07T04:47:21-04:00
base: improve error message for Data.Char.chr
As per https://github.com/haskell/core-libraries-committee/issues/384
- - - - -
b21bd52e by Simon Peyton Jones at 2026-04-07T04:48:07-04:00
Refactor FunResCtxt a bit
Fixes #27154
- - - - -
7fe84ea5 by Zubin Duggal at 2026-04-07T19:11:52+05:30
compiler: Warn when -finfo-table-map is used with -fllvm
These are currently not supported together.
Fixes #26435
- - - - -
239 changed files:
- .gitlab/issue_templates/default.md
- compiler/GHC.hs
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.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/Tidy.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Phases.hs
- compiler/GHC/Driver/Session.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/Hs/Utils.hs
- compiler/GHC/HsToCore/Binds.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/Iface/Syntax.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Parser/HaddockLex.x
- 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/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Rename/Splice.hs-boot
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Stg/Lint.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/Hole.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/Instance/Family.hs
- compiler/GHC/Tc/Instance/FunDeps.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/TyCl/Utils.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/Evidence.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
- 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/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/Name/Set.hs
- compiler/GHC/Types/SrcLoc.hs
- + compiler/GHC/Types/Var/FV.hs
- compiler/GHC/Types/Var/Set.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/State.hs
- + compiler/GHC/Unit/State.hs-boot
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/EndoOS.hs
- − compiler/GHC/Utils/FV.hs
- compiler/GHC/Utils/Logger.hs
- compiler/GHC/Utils/Trace.hs
- compiler/Language/Haskell/Syntax/Module/Name.hs
- compiler/ghc.cabal.in
- docs/users_guide/debug-info.rst
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Info.hs
- libraries/base/changelog.md
- libraries/base/tests/enum01.stdout
- libraries/base/tests/enum01.stdout-alpha-dec-osf3
- libraries/base/tests/enum01.stdout-ws-64
- libraries/ghc-internal/src/GHC/Internal/Char.hs
- rts/HeapStackCheck.cmm
- rts/RtsSymbols.c
- rts/include/stg/MiscClosures.h
- testsuite/driver/testlib.py
- testsuite/tests/arityanal/should_compile/Arity01.stderr
- testsuite/tests/arityanal/should_compile/Arity05.stderr
- testsuite/tests/arityanal/should_compile/Arity08.stderr
- testsuite/tests/arityanal/should_compile/Arity11.stderr
- testsuite/tests/arityanal/should_compile/Arity14.stderr
- 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/driver/T26435.ghc.stderr
- + testsuite/tests/driver/T26435.hs
- + testsuite/tests/driver/T26435.stdout
- testsuite/tests/driver/all.T
- 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/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/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/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/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/polykinds/T15789.stderr
- testsuite/tests/polykinds/T18451.stderr
- testsuite/tests/polykinds/T7328.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/simplCore/should_compile/DsSpecPragmas.stderr
- testsuite/tests/simplCore/should_compile/T15205.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/ExpansionQLIm.hs
- testsuite/tests/typecheck/should_compile/T14590.stderr
- testsuite/tests/typecheck/should_compile/T25180.stderr
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_compile/free_monad_hole_fits.stderr
- 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/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/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
- testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
- 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
- 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/-/compare/92024d717f1af51503c38eee85eb75…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/92024d717f1af51503c38eee85eb75…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding] Introduce `ModuleNameProvidersMap` use for home units
by Wolfgang Jeltsch (＠jeltsch) 07 Apr '26
by Wolfgang Jeltsch (＠jeltsch) 07 Apr '26
07 Apr '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding at Glasgow Haskell Compiler / GHC
Commits:
3cf48831 by Matthew Pickering at 2026-04-07T16:23:25+03:00
Introduce `ModuleNameProvidersMap` use for home units
This contribution introduces a home modules cache to the module graph
and changes the finder to use that cache to cut down home unit search
work. The particular changes are as follows:
* In `GHC.Unit.Module.Graph`, `ModuleGraph` is extended with a new
field `mg_home_map`, exposed as `mgHomeModuleMap`. This is a data
structure that caches the following:
- The set of home units for which the graph has a complete
module listing
- For each module name, the set of home unit IDs that define it
Operations that construct module graphs are updated such that this
cache stays synchronized.
* In `GHC.Unit.Finder`, `findImportedModule` is changed to pull
`mgHomeModuleMap` from `hsc_mod_graph` and pass it to
`findImportedModuleNoHsc`, which first consults the cache to find
the home unit of the respective module and only falls back to the
usual search when that home unit could not be found via the cache.
The practical effect is that for unqualified and `this-package` imports,
the finder avoids blindly searching every home unit dependency when the
current module graph already states which units may provide that module.
This is a performance optimization, especially for multi-home-unit
builds.
Resolves #27055.
Co-authored-by: Wolfgang Jeltsch <wolfgang(a)well-typed.com>
- - - - -
2 changed files:
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/Graph.hs
Changes:
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -44,6 +44,7 @@ import GHC.Data.OsPath
import GHC.Unit.Env
import GHC.Unit.Types
import GHC.Unit.Module
+import GHC.Unit.Module.Graph (ModuleNameHomeMap (..), mgHomeModuleMap)
import GHC.Unit.Home
import GHC.Unit.Home.Graph (UnitEnvGraph)
import qualified GHC.Unit.Home.Graph as HUG
@@ -72,7 +73,7 @@ import GHC.Driver.Config.Finder
import GHC.Types.Unique.Set
import qualified Data.List as L(sort)
import Data.List.NonEmpty ( NonEmpty (..) )
-import qualified Data.Set as Set (toList)
+import qualified Data.Set as Set
import qualified System.Directory as SD
import qualified System.OsPath as OsPath
import qualified Data.List.NonEmpty as NE
@@ -182,7 +183,8 @@ findImportedModule hsc_env mod pkg_qual =
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+ let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) home_module_map mhome_unit mod pkg_qual
findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult
findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do
@@ -195,22 +197,27 @@ findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> ModuleNameHomeMap
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
- | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
+ | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os)
| otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))
OtherPkg _ -> pkg_import
where
+ ModuleNameHomeMap complete_units module_name_map = home_module_map
+ module_home_units = M.findWithDefault Set.empty mod_name module_name_map
+ current_unit_id = homeUnitId <$> mhome_unit
all_opts = case mhome_unit of
- Nothing -> other_fopts
- Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts
+ Nothing -> other_fopts_list
+ Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list
+ other_fopts_map = M.fromList other_fopts_list
home_import = case mhome_unit of
Just home_unit -> findHomeModule fc fopts home_unit mod_name
@@ -221,7 +228,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name =
- findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue home_module_map (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual
| elementOfUniqSet mod_name (finder_hiddenModules opts) =
return (mkHomeHidden uid)
| otherwise =
@@ -230,7 +237,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- Do not be smart and change this to `foldr orIfNotFound home_import hs` as
-- that is not the same!! home_import is first because we need to look within ourselves
-- first before looking at the packages in order.
- any_home_import = foldr1 orIfNotFound (home_import:| map home_pkg_import other_fopts)
+ any_home_import = foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts_list)
pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
@@ -241,9 +248,21 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
units = case mhome_unit of
Nothing -> ue_homeUnitState ue
Just home_unit -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
- hpt_deps :: [UnitId]
- hpt_deps = Set.toList (homeUnitDepends units)
- other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps
+ hpt_deps :: Set.Set UnitId
+ hpt_deps = homeUnitDepends units
+ dep_providers = Set.intersection module_home_units hpt_deps
+ known_other_uids =
+ let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id
+ in Set.toList providers
+ unknown_units =
+ let candidates = Set.difference hpt_deps complete_units
+ excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id
+ in Set.toList (Set.difference candidates excluded)
+ other_home_uids = known_other_uids ++ unknown_units
+ other_fopts_list =
+ [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))
+ | uid <- other_home_uids
+ ]
-- | Locate a plugin module requested by the user, for a compiler
-- plugin. This consults the same set of exposed packages as
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -67,6 +67,8 @@ module GHC.Unit.Module.Graph
, mgLookupModule
, mgLookupModuleName
, mgHasHoles
+ , ModuleNameHomeMap (ModuleNameHomeMap)
+ , mgHomeModuleMap
, showModMsg
-- ** Reachability queries
@@ -156,10 +158,11 @@ import GHC.Unit.Module.ModIface
import GHC.Utils.Misc ( partitionWith )
import System.FilePath
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Map (Map)
import qualified Data.Map as Map
import GHC.Types.Unique.DSet
-import qualified Data.Set as Set
-import Data.Set (Set)
import GHC.Unit.Module
import GHC.Unit.Module.ModNodeKey
import GHC.Unit.Module.Stage
@@ -202,14 +205,47 @@ data ModuleGraph = ModuleGraph
-- Cached computation, whether any of the ModuleGraphNode are isHoleModule,
-- This is only used for a hack in GHC.Iface.Load to do with backpack, please
-- remove this at the earliest opportunity.
+ , mg_home_map :: ModuleNameHomeMap
+ -- ^ For each module name, which home unit UnitIds define it together with the set of units for which the listing is complete.
}
+data ModuleNameHomeMap = ModuleNameHomeMap !(Set UnitId)
+ !(Map ModuleName (Set UnitId))
+
+mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap
+mkHomeModuleMap nodes = ModuleNameHomeMap completeUnits providerMap where
+
+ providerMap :: Map ModuleName (Set UnitId)
+ providerMap
+ = Map.fromListWith Set.union $
+ [
+ (ms_mod_name modSummary, Set.singleton (ms_unitid modSummary)) |
+ ModuleNode _ (ModuleNodeCompile modSummary) <- nodes
+ ]
+
+ completeUnits :: Set UnitId
+ completeUnits
+ = Set.fromList $
+ [
+ ms_unitid modSummary |
+ ModuleNode _ (ModuleNodeCompile modSummary) <- nodes
+ ]
+
+ {-NOTE:
+ The matching with `ModuleNodeCompile` results in nodes with
+ `ModuleNodeFixed` in their info being dropped.
+ -}
+
+mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap
+mgHomeModuleMap = mg_home_map
+
-- | Why do we ever need to construct empty graphs? Is it because of one shot mode?
emptyMG :: ModuleGraph
emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing)
(graphReachability emptyGraph, const Nothing)
(graphReachability emptyGraph, const Nothing)
False
+ (ModuleNameHomeMap Set.empty Map.empty)
-- | Construct a module graph. This function should be the only entry point for
-- building a 'ModuleGraph', since it is supposed to be built once and never modified.
@@ -308,7 +344,7 @@ checkModuleGraph ModuleGraph{..} =
where
duplicate_errs = rights (Map.elems node_types)
- node_types :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
+ node_types :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
node_types = Map.fromListWithKey go [ (mkNodeKey n, Left (moduleNodeType n)) | n <- mg_mss ]
where
-- Multiple nodes with the same key are not allowed.
@@ -319,7 +355,7 @@ checkModuleGraph ModuleGraph{..} =
-- | Check that all dependencies in the graph are present in the node_types map.
-- This is a helper function used by checkModuleGraph.
-checkAllDependenciesInGraph :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
+checkAllDependenciesInGraph :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
-> ModuleGraphNode
-> Maybe ModuleGraphInvariantError
checkAllDependenciesInGraph node_types node =
@@ -334,7 +370,7 @@ checkAllDependenciesInGraph node_types node =
-- | Check if for the fixed module node invariant:
--
-- Fixed nodes can only depend on other fixed nodes.
-checkFixedModuleInvariant :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
+checkFixedModuleInvariant :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
-> ModuleGraphNode
-> Maybe ModuleGraphInvariantError
checkFixedModuleInvariant node_types node = case node of
@@ -484,13 +520,17 @@ isEmptyMG = null . mg_mss
-- To preserve invariants, 'f' can't change the isBoot status.
mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG f mg@ModuleGraph{..} = mg
- { mg_mss = flip fmap mg_mss $ \case
- InstantiationNode uid iuid -> InstantiationNode uid iuid
- LinkNode uid nks -> LinkNode uid nks
- ModuleNode deps (ModuleNodeFixed key loc) -> ModuleNode deps (ModuleNodeFixed key loc)
- ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms))
- UnitNode deps uid -> UnitNode deps uid
+ { mg_mss = new_mss
+ , mg_home_map = mkHomeModuleMap new_mss
}
+ where
+ new_mss =
+ flip fmap mg_mss $ \case
+ InstantiationNode uid iuid -> InstantiationNode uid iuid
+ LinkNode uid nks -> LinkNode uid nks
+ ModuleNode deps (ModuleNodeFixed key loc) -> ModuleNode deps (ModuleNodeFixed key loc)
+ ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms))
+ UnitNode deps uid -> UnitNode deps uid
-- | Map a function 'f' over all the 'ModSummaries', in 'IO'.
-- To preserve invariants, 'f' can't change the isBoot status.
@@ -856,7 +896,7 @@ moduleNodeInfoBootString mn@(ModuleNodeFixed {}) =
-- described in the export list haddocks.
--------------------------------------------------------------------------------
-newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }
+newtype NodeMap a = NodeMap { unNodeMap :: Map NodeKey a }
deriving (Functor, Traversable, Foldable)
-- | Transitive dependencies, including SOURCE edges
@@ -932,7 +972,7 @@ moduleGraphNodesZero summaries =
lookup_key :: ZeroScopeKey -> Maybe Int
lookup_key = fmap zeroSummaryNodeKey . lookup_node
- node_map :: Map.Map ZeroScopeKey ZeroSummaryNode
+ node_map :: Map ZeroScopeKey ZeroSummaryNode
node_map =
Map.fromList [ (s, node)
| node <- nodes
@@ -1031,7 +1071,7 @@ moduleGraphNodesStages summaries =
lookup_key :: (NodeKey, ModuleStage) -> Maybe Int
lookup_key = fmap stageSummaryNodeKey . lookup_node
- node_map :: Map.Map (NodeKey, ModuleStage) StageSummaryNode
+ node_map :: Map (NodeKey, ModuleStage) StageSummaryNode
node_map =
Map.fromList [ (s, node)
| node <- nodes
@@ -1049,10 +1089,13 @@ moduleGraphNodesStages summaries =
extendMG :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
extendMG ModuleGraph{..} node =
ModuleGraph
- { mg_mss = node : mg_mss
- , mg_graph = mkTransDeps (node : mg_mss)
- , mg_loop_graph = mkTransLoopDeps (node : mg_mss)
- , mg_zero_graph = mkTransZeroDeps (node : mg_mss)
+ { mg_mss = new_mss
+ , mg_graph = mkTransDeps new_mss
+ , mg_loop_graph = mkTransLoopDeps new_mss
+ , mg_zero_graph = mkTransZeroDeps new_mss
, mg_has_holes = mg_has_holes || maybe False isHsigFile (moduleNodeInfoHscSource =<< mgNodeIsModule node)
+ , mg_home_map = mkHomeModuleMap new_mss
}
+ where
+ new_mss = node : mg_mss
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3cf48831971cde68e432829a1666fa8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3cf48831971cde68e432829a1666fa8…
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-unit-imports-finding
by Wolfgang Jeltsch (＠jeltsch) 07 Apr '26
by Wolfgang Jeltsch (＠jeltsch) 07 Apr '26
07 Apr '26
Wolfgang Jeltsch pushed new branch wip/jeltsch/more-efficient-home-unit-imports-finding at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/jeltsch/more-efficient-home-u…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/reentrant-tys] Working prototype
by Andreas Klebinger (＠AndreasK) 07 Apr '26
by Andreas Klebinger (＠AndreasK) 07 Apr '26
07 Apr '26
Andreas Klebinger pushed to branch wip/andreask/reentrant-tys at Glasgow Haskell Compiler / GHC
Commits:
89da6c0f by Andreas Klebinger at 2026-04-07T12:29:28+00:00
Working prototype
- - - - -
10 changed files:
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Stg/Make.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- + testsuite/tests/perf/should_run/T27114.hs
- + testsuite/tests/perf/should_run/T27114.stdout
- testsuite/tests/perf/should_run/all.T
Changes:
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -830,7 +830,7 @@ The tyConUpdatable flag is controlled by the {-# RECOMPUTING T #-} pragma.
defaultTyConFlags :: TyConFlags
-defaultTyConFlags = TyConFlags { tyConUpdatable = False }
+defaultTyConFlags = TyConFlags { tyConUpdatable = True }
instance Binary TyConFlags where
put_ bh (TyConFlags updatable) = put_ bh updatable
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -32,6 +32,7 @@ import GHC.Types.Id.Make ( coercionTokenId )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.CostCentre
+import GHC.Types.Demand ( isAtMostOnceDmd )
import GHC.Types.Tickish
import GHC.Types.Var.Env
import GHC.Types.Name ( isExternalName )
@@ -354,7 +355,7 @@ coreToTopStgRhs opts this_mod ccs (bndr, rhs)
; let (stg_rhs, ccs') =
mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts))
(coreToStg_AutoSccsOnIndividualCafs opts)
- this_mod ccs bndr new_rhs
+ this_mod ccs (mkStgUpdateFlag bndr new_rhs) bndr new_rhs
stg_arity =
stgRhsArity stg_rhs
@@ -704,7 +705,7 @@ coreToStgRhs :: (Id,CoreExpr)
coreToStgRhs (bndr, rhs) = do
new_rhs <- coreToMkStgRhs bndr rhs
- return (mkStgRhs bndr new_rhs)
+ return (mkStgRhs (mkStgUpdateFlag bndr new_rhs) new_rhs)
-- Convert the RHS of a binding from Core to STG. This is a wrapper around
-- coreToStgExpr that can handle value lambdas.
@@ -722,6 +723,24 @@ coreToMkStgRhs bndr expr = do
}
pure mk_rhs
+mkStgUpdateFlag :: Id -> MkStgRhs -> UpdateFlag
+mkStgUpdateFlag bndr (MkStgRhs bndrs _rhs typ is_join)
+ | is_join = JumpedTo
+ | not (null bndrs) = ReEntrant
+ | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
+ | non_updatable_tycon = ReEntrant
+ | otherwise = Updatable
+ where
+ non_updatable_tycon
+ | isDataConId bndr = False
+ | otherwise =
+ case splitTyConApp_maybe typ of
+ Just (tycon, _) ->
+ if not (tyConUpdatable (tyConFlags tycon))
+ then pprTrace "nonUpdatableTyCon:" (ppr tycon) True
+ else False
+ Nothing -> False
+
-- ---------------------------------------------------------------------------
-- A monad for the core-to-STG pass
-- ---------------------------------------------------------------------------
=====================================
compiler/GHC/Stg/Make.hs
=====================================
@@ -19,8 +19,8 @@ import GHC.Stg.Utils (stripStgTicksTop)
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.CostCentre
-import GHC.Types.Demand ( isAtMostOnceDmd )
import GHC.Types.Tickish
+import GHC.Types.Demand (isAtMostOnceDmd)
-- Represents the RHS of a binding for use with mk(Top)StgRhs and
-- mk(Top)StgRhsCon_maybe.
@@ -36,8 +36,8 @@ data MkStgRhs = MkStgRhs
-- appended to `CollectedCCs` argument.
mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool)
-> Bool -> Module -> CollectedCCs
- -> Id -> MkStgRhs -> (StgRhs, CollectedCCs)
-mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bndr mk_rhs@(MkStgRhs bndrs rhs typ _)
+ -> UpdateFlag -> Id -> MkStgRhs -> (StgRhs, CollectedCCs)
+mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs upd_flag_core bndr mk_rhs@(MkStgRhs bndrs rhs typ _)
-- try to make a StgRhsCon first
| Just rhs_con <- mkTopStgRhsCon_maybe (allow_toplevel_con_app this_mod) mk_rhs
= ( rhs_con, ccs )
@@ -46,7 +46,7 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd
= -- The list of arguments is non-empty, so not CAF
( StgRhsClosure noExtFieldSilent
dontCareCCS
- ReEntrant
+ upd_flag
bndrs rhs typ
, ccs )
@@ -65,7 +65,7 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd
where
upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
- | otherwise = Updatable
+ | otherwise = upd_flag_core
-- CAF cost centres generated for -fcaf-all
caf_cc = mkAutoCC bndr modl
@@ -81,8 +81,8 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd
-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
-- see Note [Cost-centre initialization plan].
-mkStgRhs :: Id -> MkStgRhs -> StgRhs
-mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join)
+mkStgRhs :: UpdateFlag -> MkStgRhs -> StgRhs
+mkStgRhs upd_flag mk_rhs@(MkStgRhs bndrs rhs typ _is_join)
-- try to make a StgRhsCon first
| Just rhs_con <- mkStgRhsCon_maybe mk_rhs
= rhs_con
@@ -91,11 +91,6 @@ mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join)
= StgRhsClosure noExtFieldSilent
currentCCS
upd_flag bndrs rhs typ
- where
- upd_flag | is_join = JumpedTo
- | not (null bndrs) = ReEntrant
- | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
- | otherwise = Updatable
{-
SDM: disabled. Eval/Apply can't handle functions with arity zero very
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -785,15 +785,18 @@ tcRnHsBootDecls boot_or_sig decls
= do { (first_group, group_tail) <- findSplice decls
-- Rename the declarations
- ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
- , hs_derivds = deriv_decls
- , hs_fords = for_decls
- , hs_defds = def_decls
- , hs_ruleds = rule_decls
- , hs_annds = _
- , hs_valds = XValBindsLR (HsVBG val_binds val_sigs) })
+ ; (tcg_env0, HsGroup { hs_tyclds = tycl_decls
+ , hs_derivds = deriv_decls
+ , hs_fords = for_decls
+ , hs_defds = def_decls
+ , hs_ruleds = rule_decls
+ , hs_annds = _
+ , hs_recomputing_tyds = recomputing_tycons
+ , hs_valds = XValBindsLR (HsVBG val_binds val_sigs) })
<- rnTopSrcDecls first_group
+ ; let tcg_env = extendRecomputingTyCons recomputing_tycons tcg_env0
+
; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {
-- NB: setGblEnv **before** captureTopConstraints so that
-- if the latter reports errors, it knows what's in scope
@@ -1699,6 +1702,13 @@ rnTopSrcDecls group
return (tcg_env', rn_decls)
}
+extendRecomputingTyCons :: [LIdP GhcRn] -> TcGblEnv -> TcGblEnv
+extendRecomputingTyCons tycons tcg_env
+ = tcg_env
+ { tcg_recomputing_tycons =
+ tcg_recomputing_tycons tcg_env `unionNameSet`
+ mkNameSet (map unLoc tycons) }
+
tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
hs_derivds = deriv_decls,
@@ -1706,9 +1716,12 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
hs_defds = default_decls,
hs_annds = annotation_decls,
hs_ruleds = rule_decls,
+ hs_recomputing_tyds = recomputing_tycons,
hs_valds = hs_val_binds@(XValBindsLR
(HsVBG val_binds val_sigs)) })
- = do { -- Type-check the type and class decls, and all imported decls
+ = do { tcg_env <- getGblEnv
+ ; setGblEnv (extendRecomputingTyCons recomputing_tycons tcg_env) $ do {
+ -- Type-check the type and class decls, and all imported decls
-- The latter come in via tycl_decls
traceTc "Tc2 (src)" empty ;
@@ -1785,7 +1798,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ;
return (tcg_env', tcl_env)
- }}}}}
+ }}}}}}
tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -3595,6 +3595,13 @@ tcDataDefn err_ctxt roles_info tc_name
; res_kind <- zonkTcTypeToTypeX res_kind
; return (kind, bndrs, stupid_theta, res_kind) }
+ ; tcg_env <- getGblEnv
+ ; let tycon_flags
+ | tc_name `elemNameSet` tcg_recomputing_tycons tcg_env
+ = defaultTyConFlags { tyConUpdatable = False }
+ | otherwise
+ = defaultTyConFlags
+
; tycon <- fixM $ \ rec_tycon -> do
{ data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons
; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons
@@ -3603,7 +3610,7 @@ tcDataDefn err_ctxt roles_info tc_name
bndrs nb_eta
res_kind
(roles_info tc_name)
- defaultTyConFlags
+ tycon_flags
(fmap (typeCheckCType . unLoc) cType)
stupid_theta tc_rhs
(VanillaAlgTyCon tc_rep_nm)
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -644,6 +644,7 @@ data TcGblEnv
tcg_rules :: [LRuleDecl GhcTc], -- ...Rules
tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports
tcg_patsyns :: [PatSyn], -- ...Pattern synonyms
+ tcg_recomputing_tycons :: NameSet, -- ...TyCons marked by RECOMPUTING pragmas
tcg_hdr_info :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)),
-- ^ Maybe Haddock header docs and Maybe located module name
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -384,6 +384,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc =
, tcg_rules = []
, tcg_fords = []
, tcg_patsyns = []
+ , tcg_recomputing_tycons = emptyNameSet
, tcg_merged = []
, tcg_dfun_n = dfun_n_var
, tcg_zany_n = zany_n_var
=====================================
testsuite/tests/perf/should_run/T27114.hs
=====================================
@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC
+
+-dsuppress-uniques
+
+ #-}
+module Main where
+
+import System.Environment
+
+foo :: Foldable t => t a -> Int
+foo = undefined
+
+{-# RECOMPUTING Nats #-}
+data Nats = Nats Int Nats
+
+{-# NOINLINE loop #-}
+loop :: Int -> Nats -> (Int -> IO ()) -> IO ()
+loop 0 _ _ = return ()
+loop n (Nats i is) k = k i >> loop (n - 1) is k
+
+main :: IO ()
+main = do
+ args <- getArgs
+ let count = case args of
+ (a:args) -> read $ filter (/= '_') a
+ _ -> 10_000_000
+
+ let nats n = Nats n (nats (n + 1))
+ let ele_action x = if (x `mod` (count `div` 10)) == 0 then print x else seq x (pure ())
+ loop count (nats 0) ele_action
+ -- With saring for @Nats@ disabled we will not retain the fully materialized nats data structure.
+ -- Instead the second loop will recompute it.
+ loop count (nats 0) ele_action
+
=====================================
testsuite/tests/perf/should_run/T27114.stdout
=====================================
@@ -0,0 +1,20 @@
+0
+1000000
+2000000
+3000000
+4000000
+5000000
+6000000
+7000000
+8000000
+9000000
+0
+1000000
+2000000
+3000000
+4000000
+5000000
+6000000
+7000000
+8000000
+9000000
=====================================
testsuite/tests/perf/should_run/all.T
=====================================
@@ -441,3 +441,10 @@ test('SpecTyFamRun', [ grep_errmsg(r'foo')
, collect_stats('bytes allocated', 5)],
multimod_compile_and_run,
['SpecTyFamRun', '-O2'])
+
+test('T27114',
+ [collect_runtime_residency(50),
+ only_ways(['normal'])
+ ],
+ compile_and_run,
+ ['-O'])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89da6c0f793d9d6ecc286fab30543b5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89da6c0f793d9d6ecc286fab30543b5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: base: improve error message for Data.Char.chr
by Marge Bot (＠marge-bot) 07 Apr '26
by Marge Bot (＠marge-bot) 07 Apr '26
07 Apr '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
502e6ffe by Andrew Lelechenko at 2026-04-07T04:47:21-04:00
base: improve error message for Data.Char.chr
As per https://github.com/haskell/core-libraries-committee/issues/384
- - - - -
b21bd52e by Simon Peyton Jones at 2026-04-07T04:48:07-04:00
Refactor FunResCtxt a bit
Fixes #27154
- - - - -
45fde18c by Matthew Pickering at 2026-04-07T07:55:50-04:00
packaging: correctly propagate build/host/target to bindist configure script
At the moment the host and target which we will produce a compiler for
is fixed at the initial configure time. Therefore we need to persist
the choice made at this time into the installation bindist as well so we
look for the right tools, with the right prefixes at install time.
In the future, we want to provide a bit more control about what kind of
bindist we produce so the logic about what the host/target will have to
be written by hadrian rather than persisted by the configure script. In
particular with cross compilers we want to either build a normal stage 2
cross bindist or a stage 3 bindist, which creates a bindist which has a
native compiler for the target platform.
Fixes #21970
Co-authored-by: Sven Tennie <sven.tennie(a)gmail.com>
- - - - -
dffb4e08 by Sven Tennie at 2026-04-07T07:55:51-04:00
Cross --host and --target no longer required for cross (#21970)
We set sane defaults in the configure script. Thus, these paramenters
aren't required any longer.
- - - - -
1773374b by Sven Tennie at 2026-04-07T07:55:51-04:00
ci: Define USER_CONF_CC_OPTS_STAGE2 for aarch64/mingw
ghc-toolchain doesn't see $CONF_CC_OPTS_STAGE2 when the bindist gets
configured. So, the hack to override the compiler gets lost.
- - - - -
a61597c6 by Duncan Coutts at 2026-04-07T07:55:52-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.
- - - - -
69ee18dc by Duncan Coutts at 2026-04-07T07:55:52-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).
- - - - -
e43f2f0c by Duncan Coutts at 2026-04-07T07:55:53-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.
- - - - -
0769a25d by Duncan Coutts at 2026-04-07T07:55:53-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.
- - - - -
7df6bd16 by Duncan Coutts at 2026-04-07T07:55:53-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.
- - - - -
27 changed files:
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/cfg/system.config.in
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Default.hs
- libraries/base/changelog.md
- libraries/base/tests/enum01.stdout
- libraries/base/tests/enum01.stdout-alpha-dec-osf3
- libraries/base/tests/enum01.stdout-ws-64
- libraries/ghc-internal/src/GHC/Internal/Char.hs
- m4/fptools_set_platform_vars.m4
- m4/ghc_toolchain.m4
- + 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
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -628,20 +628,6 @@ function install_bindist() {
*)
read -r -a args <<< "${INSTALL_CONFIGURE_ARGS:-}"
- if [[ "${CROSS_TARGET:-no_cross_target}" =~ "mingw" ]]; then
- # We suppose that host target = build target.
- # By the fact above it is clearly turning out which host value is
- # for currently built compiler.
- # The fix for #21970 will probably remove this if-branch.
- local -r CROSS_HOST_GUESS=$($SHELL ./config.guess)
- args+=( "--target=$CROSS_TARGET" "--host=$CROSS_HOST_GUESS" )
-
- # FIXME: The bindist configure script shouldn't need to be reminded of
- # the target platform. See #21970.
- elif [ -n "${CROSS_TARGET:-}" ]; then
- args+=( "--target=$CROSS_TARGET" "--host=$CROSS_TARGET" )
- fi
-
run ${CONFIGURE_WRAPPER:-} ./configure \
--prefix="$instdir" \
"${args[@]+"${args[@]}"}" || fail "bindist configure failed"
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -1316,6 +1316,13 @@ cross_jobs = [
-- unexpected triple.
. setVariable "CFLAGS" cflags
. setVariable "CONF_CC_OPTS_STAGE2" cflags
+ -- For bindists `$USER_CONF_CC_OPTS_STAGE2` is not automatically set
+ -- to `$CONF_CC_OPTS_STAGE2`. But, we still have to deal with the hack
+ -- mentioned in the previous comment.
+ --
+ -- TODO: It would be nice to get rid of this hack. This would probably
+ -- involve setting the toolchain up in a different way.
+ . setVariable "USER_CONF_CC_OPTS_STAGE2" cflags
) where
llvm_prefix = "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-"
cflags = "-fuse-ld=" ++ llvm_prefix ++ "ld --rtlib=compiler-rt"
=====================================
.gitlab/jobs.yaml
=====================================
@@ -331,6 +331,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres"
}
},
@@ -412,6 +413,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres"
}
},
@@ -1123,6 +1125,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres",
"XZ_OPT": "-9"
}
@@ -1205,6 +1208,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres",
"XZ_OPT": "-9"
}
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -7710,12 +7710,8 @@ pprHsCtxt = \case
PatSigErrCtxt sig_ty res_ty ->
vcat [ hang (text "When checking that the pattern signature:")
4 (ppr sig_ty)
- , nest 2 (hang (text "fits the type of its context:") 2 pp_res_ty) ]
- where
- -- Zonking will have turned Infer into Check
- pp_res_ty = case res_ty of
- Check ty -> ppr ty
- Infer ir -> text "OOPS" <+> ppr ir
+ , nest 2 (hang (text "fits the type of its context:")
+ 2 (ppr (getCheckExpType res_ty))) ]
PatCtxt pat ->
hang (text "In the pattern:") 2 (ppr pat)
@@ -7777,7 +7773,7 @@ pprHsCtxt = \case
full_herald = pprExpectedFunTyHerald herald
<+> speakNOf n_vis_args_in_call (text "visible argument")
-- What are "visible" arguments? See Note [Visibility and arity] in GHC.Types.Basic
- FunResCtxt fun n_val_args res_fun res_env n_fun n_env
+ FunResCtxt fun n_val_args fun_res_ty env_ty
| -- Check for too few args
-- fun_tau = a -> b, res_tau = Int
n_fun > n_env
@@ -7801,6 +7797,18 @@ pprHsCtxt = \case
-> empty
-- text "Debug" <+> vcat [ppr fun, ppr n_val_args, ppr res_fun, ppr res_env, ppr n_fun, ppr n_env]
where
+ -- See Note [Splitting nested sigma types in mismatched
+ -- function types]
+ -- env_ty is an ExpRhoTy, but with simple subsumption it
+ -- is not /deeply/ skolemised, so still use tcSplitNestedSigmaTys
+
+ (_,_,fun_tau) = tcSplitNestedSigmaTys fun_res_ty
+ (_, _, env_tau) = tcSplitNestedSigmaTys (getCheckExpType env_ty)
+ (args_fun, res_fun) = tcSplitFunTys fun_tau
+ (args_env, res_env) = tcSplitFunTys env_tau
+ n_fun = length args_fun
+ n_env = length args_env
+
not_fun ty -- ty is definitely not an arrow type,
-- and cannot conceivably become one
= case tcSplitTyConApp_maybe ty of
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -68,7 +68,6 @@ import GHC.Builtin.Names
import GHC.Driver.DynFlags
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
import GHC.Data.Maybe
@@ -961,7 +960,8 @@ See Note [-fno-code mode].
* *
********************************************************************* -}
-addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p]
+addFunResCtxt :: HasDebugCallStack
+ => HsExpr GhcTc -> [HsExprArg p]
-> TcType -> ExpRhoType
-> TcM a -> TcM a
-- When we have a mis-match in the return type of a function
@@ -969,33 +969,10 @@ addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p]
-- But not in generated code, where we don't want
-- to mention internal (rebindable syntax) function names
addFunResCtxt fun args fun_res_ty env_ty thing_inside
- = do { env_tv <- newFlexiTyVarTy liftedTypeKind
- ; dumping <- doptM Opt_D_dump_tc_trace
- ; msg <- mk_msg dumping env_tv
- ; addErrCtxt msg thing_inside }
+ = addErrCtxt (FunResCtxt fun (count isValArg args) fun_res_ty env_ty) $
+ thing_inside
-- NB: use a landmark error context, so that an empty context
-- doesn't suppress some more useful context
- where
- mk_msg dumping env_tv
- = do { mb_env_ty <- readExpType_maybe env_ty
- -- by the time the message is rendered, the ExpType
- -- will be filled in (except if we're debugging)
- ; env' <- case mb_env_ty of
- Just env_ty -> return env_ty
- Nothing -> do { massert dumping; return env_tv }
- ; let -- See Note [Splitting nested sigma types in mismatched
- -- function types]
- (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res_ty
- (_, _, env_tau) = tcSplitNestedSigmaTys env'
- -- env_ty is an ExpRhoTy, but with simple subsumption it
- -- is not deeply skolemised, so still use tcSplitNestedSigmaTys
- (args_fun, res_fun) = tcSplitFunTys fun_tau
- (args_env, res_env) = tcSplitFunTys env_tau
- info =
- FunResCtxt fun (count isValArg args) res_fun res_env
- (length args_fun) (length args_env)
- ; return info }
-
{-
Note [Splitting nested sigma types in mismatched function types]
=====================================
compiler/GHC/Tc/Types/ErrCtxt.hs
=====================================
@@ -251,7 +251,10 @@ data HsCtxt
-- | In the instance type signature of a class method.
| MethSigCtxt !Name !TcType !TcType
-- | In a pattern type signature.
+
| PatSigErrCtxt !TcType !ExpType
+ -- ExpType: see Note [ExpType in HsCtxt]
+
-- | In a pattern.
| PatCtxt !(Pat GhcRn)
-- | In a pattern synonym declaration.
@@ -268,7 +271,10 @@ data HsCtxt
-- | In a function call.
| FunTysCtxt !ExpectedFunTyCtxt !Type !Int !Int
-- | In the result of a function call.
- | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int
+
+ | FunResCtxt !(HsExpr GhcTc) !Int !TcType !ExpType
+ -- ExpType: see Note [ExpType in HsCtxt]
+
-- | In the declaration of a type constructor.
| TyConDeclCtxt !Name !(TyConFlavour TyCon)
-- | In a type or data family instance (or default instance).
@@ -377,3 +383,14 @@ isHsCtxtLandmark (DerivBindCtxt{}) = True
isHsCtxtLandmark (FunResCtxt{}) = True
isHsCtxtLandmark (VDQWarningCtxt{}) = True
isHsCtxtLandmark _ = False
+
+{- Note [ExpType in HsCtxt]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A couple of HsCtxt constructors have ExpTypes in them. When zonking the
+Infer{} case we read the hole, which should be filled in by now, and zonk
+that type. Now we want to put it back: we use (Check ty') for this, so that
+clients of a zonked HsCtxt don't need to be monadic.
+
+Result: after zonking, these ExpTypes are always (Check ty). It woudl be nice
+to guarantee this statically, but it's hard to do so.
+-}
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -28,7 +28,7 @@ module GHC.Tc.Utils.TcType (
ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..),
ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR,
ExpRhoType, ExpRhoTypeFRR,
- mkCheckExpType,
+ mkCheckExpType, getCheckExpType,
checkingExpType_maybe, checkingExpType,
ExpPatType(..), mkCheckExpFunPatTy, mkInvisExpPatType,
@@ -440,11 +440,12 @@ data InferInstFlag -- Specifies whether the inference should return an uninstan
| IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top)
-- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole
- -- Typically used when inferring the type of an expression
+ -- Used only for view patterns; see Note [View patterns and polymorphism]
| IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption)
-- If DeepSubsumption is off, same as IIF_ShallowRho
-- If DeepSubsumption is on, instantiate deeply before filling the hole
+ -- Typically used when inferring the type of an expression
type ExpSigmaType = ExpType
type ExpRhoType = ExpType
@@ -490,6 +491,12 @@ instance Outputable InferResult where
mkCheckExpType :: TcType -> ExpType
mkCheckExpType = Check
+getCheckExpType :: HasDebugCallStack => ExpType -> TcType
+-- Expect a (Check ty).
+-- See Note [ExpType in HsCtxt] in GHC.Tc.Types.ErrCtxt
+getCheckExpType (Check ty) = ty
+getCheckExpType (Infer ir) = pprPanic "getCheckExpType" (ppr ir)
+
-- | Returns the expected type when in checking mode.
checkingExpType_maybe :: ExpType -> Maybe TcType
checkingExpType_maybe (Check ty) = Just ty
=====================================
compiler/GHC/Tc/Zonk/TcType.hs
=====================================
@@ -818,19 +818,26 @@ zonkTidyHsCtxt env e@(FunAppCtxt{}) = return (env, e)
zonkTidyHsCtxt env (FunTysCtxt ctxt ty i1 i2) = do
(env', ty') <- zonkTidyTcType env ty
return $ (env', FunTysCtxt ctxt ty' i1 i2)
-zonkTidyHsCtxt env (FunResCtxt e i1 ty1 ty2 i2 i3) = do
- (env', ty1') <- zonkTidyTcType env ty1
- (env', ty2') <- zonkTidyTcType env' ty2
- return $ (env', FunResCtxt e i1 ty1' ty2' i2 i3)
+zonkTidyHsCtxt env (FunResCtxt e n ty1 env_ty) = do
+ (env', ty1') <- zonkTidyTcType env ty1
+ (env', env_ty') <- zonkExpType env' env_ty
+ return $ (env', FunResCtxt e n ty1' env_ty')
zonkTidyHsCtxt env (PatSigErrCtxt sig_ty res_ty) = do
(env', sig_ty') <- zonkTidyTcType env sig_ty
- (env', res_ty') <-
- case res_ty of
- Check ty -> zonkTidyTcType env' ty
- Infer (IR {ir_ref = ref}) -> do -- inlining readExpTyp_maybe to avoid module dep loops
- mb_ty <- liftIO $ readIORef ref
- case mb_ty of
- Nothing -> error "zonkTidyHsCtxt PatSigErrCtxt"
- Just ty -> zonkTidyTcType env' ty
- return (env', PatSigErrCtxt sig_ty' (Check res_ty'))
+ (env', res_ty') <- zonkExpType env' res_ty
+ return (env', PatSigErrCtxt sig_ty' res_ty')
zonkTidyHsCtxt env p = return (env, p)
+
+zonkExpType :: TidyEnv -> ExpType -> ZonkM (TidyEnv, ExpType)
+-- Zonk Infer{} to Check. The hole should have been filled in by now
+zonkExpType env (Check ty)
+ = do { (env', ty') <- zonkTidyTcType env ty
+ ; return (env', Check ty') }
+zonkExpType env (Infer ir@(IR { ir_ref = ref }))
+ = do { -- inlining readExpTyp_maybe to avoid module dep loops
+ ; mb_ty <- liftIO $ readIORef ref
+ ; case mb_ty of
+ Nothing -> pprPanic "zonkTidyHsCtxt PatSigErrCtxt" (ppr ir)
+ Just ty -> do { (env', ty') <- zonkTidyTcType env ty
+ ; return (env', Check ty') } }
+
=====================================
configure.ac
=====================================
@@ -255,6 +255,7 @@ if test "${WithGhc}" != ""
then
bootstrap_host=`"${WithGhc}" --info | grep '^ ,("Host platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'`
bootstrap_target=`"${WithGhc}" --info | grep '^ ,("Target platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'`
+ bootstrap_build="$bootstrap_host"
if test "$bootstrap_host" != "$bootstrap_target"
then
echo "Bootstrapping GHC is a cross compiler. This probably isn't going to work"
@@ -394,8 +395,33 @@ then
else
TargetPlatformFull="${target_alias}"
fi
+
+if test -z "${build_alias}"
+then
+ # --target wasn't given; use result from AC_CANONICAL_TARGET
+ BuildPlatformFull="${build}"
+else
+ BuildPlatformFull="${build_alias}"
+fi
+if test -z "${host_alias}"
+then
+ # --target wasn't given; use result from AC_CANONICAL_TARGET
+ HostPlatformFull="${host}"
+else
+ HostPlatformFull="${host_alias}"
+fi
+if test "$CrossCompiling" = "YES"
+then
+ # Use value passed by user from --target=
+ CrossCompilePrefix="${TargetPlatformFull}-"
+else
+ CrossCompilePrefix=""
+fi
+
AC_SUBST(CrossCompiling)
AC_SUBST(TargetPlatformFull)
+AC_SUBST(BuildPlatformFull)
+AC_SUBST(HostPlatformFull)
dnl ** Which gcc to use?
dnl --------------------------------------------------------------
=====================================
distrib/configure.ac.in
=====================================
@@ -15,7 +15,18 @@ dnl--------------------------------------------------------------------
dnl * Deal with arguments telling us gmp is somewhere odd
dnl--------------------------------------------------------------------
+build_alias=@BuildPlatformFull@
+host_alias=@HostPlatformFull@
+target_alias=@TargetPlatformFull@
+
+dnl this makes sure `./configure --target=<cross-compile-target>`
+dnl works as expected, since we're slightly modifying how Autoconf
+dnl interprets build/host/target and how this interacts with $CC tests
+test -n "$target_alias" && ac_tool_prefix=$target_alias-
+
dnl Various things from the source distribution configure
+bootstrap_build=@BuildPlatform@
+bootstrap_host=@HostPlatform@
bootstrap_target=@TargetPlatform@
bootstrap_llvm_target=@LlvmTarget@
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -50,6 +50,9 @@ use-ghc-toolchain = @EnableGhcToolchain@
# And we can reconstruct the platform info using targetPlatformTriple
# Q: What is TargetPlatformFull?
target-platform-full = @TargetPlatformFull@
+build-platform-full = @BuildPlatformFull@
+host-platform-full = @HostPlatformFull@
+
cross-compiling = @CrossCompiling@
=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -69,6 +69,8 @@ data Setting = CursesIncludeDir
| ProjectPatchLevel2
| SystemGhc
| TargetPlatformFull
+ | BuildPlatformFull
+ | HostPlatformFull
| BourneShell
| EmsdkVersion
@@ -107,6 +109,8 @@ setting key = lookupSystemConfig $ case key of
ProjectPatchLevel2 -> "project-patch-level2"
SystemGhc -> "system-ghc"
TargetPlatformFull -> "target-platform-full"
+ BuildPlatformFull -> "build-platform-full"
+ HostPlatformFull -> "host-platform-full"
BourneShell -> "bourne-shell"
EmsdkVersion -> "emsdk-version"
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -424,6 +424,8 @@ bindistRules = do
, interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode
, interpolateVar "TargetHasLibm" $ yesNo <$> getTarget tgtHasLibm
, interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple
+ , interpolateVar "BuildPlatform" $ interp $ queryBuild targetPlatformTriple
+ , interpolateVar "HostPlatform" $ interp $ queryHost targetPlatformTriple
, interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian
, interpolateVar "TargetWordSize" $ getTarget wordSize
, interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised
@@ -431,6 +433,9 @@ bindistRules = do
, interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors
, interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP
, interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base
+ , interpolateVar "TargetPlatformFull" (setting TargetPlatformFull)
+ , interpolateVar "BuildPlatformFull" (setting BuildPlatformFull)
+ , interpolateVar "HostPlatformFull" (setting HostPlatformFull)
]
where
interp = interpretInContext (semiEmptyTarget Stage2)
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -122,7 +122,11 @@ stage0Packages = do
-- for upper stages. As we only use stage0 to build upper stages,
-- this should be fine.
++ [ terminfo | not windowsHost, not cross ]
- ++ [ timeout | windowsHost ]
+ ++ [ timeout | windowsHost ]
+ -- Due to some weird logic, we need ghcToolchainBin in Stage0 and
+ -- Stage1 packages if we're cross compiling. "Stage2 cross-compilers"
+ -- will solve this.
+ ++ [ ghcToolchainBin | cross ]
-- | Packages built in 'Stage1' by default. You can change this in "UserSettings".
stage1Packages :: Action [Package]
@@ -181,12 +185,12 @@ stage1Packages = do
, transformers
, unlit
, xhtml
+ , ghcToolchainBin
, if winTarget then win32 else unix
]
, when (not cross)
[ hpcBin
, runGhc
- , ghcToolchainBin
]
, when (winTarget && not cross)
[ -- See Note [Hadrian's ghci-wrapper package]
=====================================
libraries/base/changelog.md
=====================================
@@ -28,6 +28,7 @@
* Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387))
* Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371))
* Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397))
+ * Improve error message for `Data.Char.chr`. ([CLC Proposal #384](https://github.com/haskell/core-libraries-committee/issues/384))
## 4.22.0.0 *TBA*
* Shipped with GHC 9.14.1
=====================================
libraries/base/tests/enum01.stdout
=====================================
@@ -81,7 +81,7 @@ Testing Enum Char:
pred (maxBound::Char) = '\1114110'
pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument"
(map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111"
- (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument: (-2147483648)"
+ (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111: (-2147483648)"
(map fromEnum ['X',minBound,maxBound]) = [88,0,1114111]
(take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK"
(take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256"
=====================================
libraries/base/tests/enum01.stdout-alpha-dec-osf3
=====================================
@@ -65,7 +65,7 @@ Testing Enum Char:
pred (maxBound::Char) = '\1114110'
pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument"
(map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111"
- (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument"
+ (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111:"
(map fromEnum ['X',minBound,maxBound]) = [88,0,1114111]
(take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK"
(take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256"
=====================================
libraries/base/tests/enum01.stdout-ws-64
=====================================
@@ -81,7 +81,7 @@ Testing Enum Char:
pred (maxBound::Char) = '\1114110'
pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument"
(map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111"
- (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument: (-9223372036854775808)"
+ (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111: (-9223372036854775808)"
(map fromEnum ['X',minBound,maxBound]) = [88,0,1114111]
(take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK"
(take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256"
=====================================
libraries/ghc-internal/src/GHC/Internal/Char.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Internal.Char
import GHC.Internal.Classes (eqChar, neChar)
import GHC.Internal.Base (otherwise, (++))
-import GHC.Internal.Err (errorWithoutStackTrace)
+import GHC.Internal.Err (error)
import GHC.Internal.Show
import GHC.Internal.Prim (chr#, int2Word#, leWord#, Int#, Char#)
import GHC.Internal.Types (Char(..), Int(..), isTrue#)
@@ -29,4 +29,7 @@ safe_chr# i#
{-# NOINLINE chr_error #-}
chr_error :: Int# -> Char#
-chr_error i# = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) (I# i#) "")
+chr_error i# = error ("Data.Char.chr: argument outside Unicode range: 0..1114111: " ++ showSignedInt (I# 9#) (I# i#) "")
+-- It's not really "Data.Char", but we assume that
+-- the majority of users will import it from "base:Data.Char"
+-- and not from "ghc-internal:GHC.Internal.Char".
=====================================
m4/fptools_set_platform_vars.m4
=====================================
@@ -77,9 +77,9 @@ dnl fi
# compiler's target platform.
AC_DEFUN([FPTOOLS_OVERRIDE_PLATFORM_FROM_BOOTSTRAP],
[
- if test "$bootstrap_target" != ""
+ if test "$bootstrap_$1" != ""
then
- $1=$bootstrap_target
+ $1=$bootstrap_$1
echo "$1 platform inferred as: [$]$1"
else
echo "Can't work out $1 platform"
=====================================
m4/ghc_toolchain.m4
=====================================
@@ -136,8 +136,10 @@ dnl and that we must compile ghc-toolchain before invoking it
AC_DEFUN([FIND_GHC_TOOLCHAIN_BIN],[
case "$1" in
YES)
- # We're configuring the bindist, and the binary is already available
- GHC_TOOLCHAIN_BIN="bin/ghc-toolchain-bin"
+ # We're configuring the bindist, and the binary is already available.
+ # For cross-compilation bindists, Hadrian names the binary with the
+ # cross-compile prefix (e.g. riscv64-linux-gnu-ghc-toolchain-bin).
+ GHC_TOOLCHAIN_BIN="bin/${CrossCompilePrefix}ghc-toolchain-bin"
;;
NO)
# We're in the source tree, so compile ghc-toolchain
=====================================
rts/posix/FdWakeup.c
=====================================
@@ -0,0 +1,141 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2025
+ *
+ * Utilities for a simple fd-based cross-thread wakeup mechanism.
+ *
+ * This is used to provide a mechanism to wake a thread when it is blocked
+ * waiting on fds and timeouts. The mechanism works by including the read end
+ * fd into the set of fds the thread waits on, and when a wake up is needed,
+ * the write end fd is used.
+ *
+ * This is implemented using either eventfd() or pipe().
+ *
+ * Linux 2.6.22+ and FreeBSD 13+ support eventfd. It is a single fd with a
+ * 64bit counter. It uses fewer resources than a pipe (less memory and one
+ * rather than two fds), and is a tad faster (on the order of 5-10%). Using
+ * write() adds to the counter, while read() reads and resets it. Thus
+ * multiple writes are combined automatically into a single corresponding
+ * read.
+ *
+ * Otherwise we use a classic unix pipe.
+ *
+ * In both implementations, multiple sendFdWakeup notifcations (without
+ * interleaved collectFdWakeup) are combined to a single notification. This
+ * is automatic given the semantics of eventfd, while for pipe we implement
+ * it explicitly by draining the pipe in collectFdWakeup.
+ *
+ * -------------------------------------------------------------------------*/
+
+#include "rts/PosixSource.h"
+#include "Rts.h"
+
+#include "FdWakeup.h"
+
+#include <fcntl.h>
+#include <unistd.h>
+
+#ifdef HAVE_SYS_EVENTFD_H
+#include <sys/eventfd.h>
+#endif
+
+#if !defined(HAVE_EVENTFD) \
+ || (defined(HAVE_EVENTFD) && !(defined(EFD_CLOEXEC) && defined(EFD_NONBLOCK)))
+static void fcntl_CLOEXEC_NONBLOCK(int fd)
+{
+ int res1 = fcntl(fd, F_SETFD, FD_CLOEXEC);
+ int res2 = fcntl(fd, F_SETFL, O_NONBLOCK);
+ if (RTS_UNLIKELY(res1 < 0 || res2 < 0)) {
+ sysErrorBelch("newFdWakeup fcntl()");
+ stg_exit(EXIT_FAILURE);
+ }
+}
+#endif
+
+void newFdWakeup(int *wakeup_fd_r, int *wakeup_fd_w)
+{
+#if defined(HAVE_EVENTFD)
+ int wakeup_fd;
+#if defined(EFD_CLOEXEC) && defined(EFD_NONBLOCK)
+ wakeup_fd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK);
+#else
+ wakeup_fd = eventfd(0, 0);
+ if (wakeup_fd >= 0) fcntl_CLOEXEC_NONBLOCK(wakeup_fd);
+#endif
+ if (RTS_UNLIKELY(wakeup_fd < 0)) {
+ sysErrorBelch("newFdWakeup eventfd()");
+ stg_exit(EXIT_FAILURE);
+ }
+ /* eventfd uses the same fd for each end */
+ *wakeup_fd_r = wakeup_fd;
+ *wakeup_fd_w = wakeup_fd;
+#else
+ int pipefd[2];
+ int res;
+ res = pipe(pipefd);
+ if (RTS_UNLIKELY(res < 0)) {
+ sysErrorBelch("newFdWakeup pipe");
+ stg_exit(EXIT_FAILURE);
+ }
+ fcntl_CLOEXEC_NONBLOCK(pipefd[0]);
+ fcntl_CLOEXEC_NONBLOCK(pipefd[1]);
+ *wakeup_fd_r = pipefd[0]; /* read end */
+ *wakeup_fd_w = pipefd[1]; /* write end */
+#endif
+}
+
+void closeFdWakeup(int wakeup_fd_r, int wakeup_fd_w)
+{
+#if defined(HAVE_EVENTFD)
+ ASSERT(wakeup_fd_r == wakeup_fd_w);
+ close(wakeup_fd_r);
+#else
+ ASSERT(wakeup_fd_r != wakeup_fd_w);
+ close(wakeup_fd_r);
+ close(wakeup_fd_w);
+#endif
+}
+
+/* This is safe to use from a signal handler. Using write() to a pipe
+ * or eventfd is fine. */
+void sendFdWakeup(int wakeup_fd_w)
+{
+ int res;
+#if defined(HAVE_EVENTFD)
+ uint64_t val = 1;
+ res = write(wakeup_fd_w, &val, 8);
+#else
+ unsigned char buf = 1;
+ res = write(wakeup_fd_w, &buf, 1);
+#endif
+ if (RTS_UNLIKELY(res < 0)) {
+ /* Unlikely the pipe buffer will fill, but it would not be an error. */
+ if (errno == EAGAIN) return;
+ sysErrorBelch("sendFdWakeup write");
+ stg_exit(EXIT_FAILURE);
+ }
+}
+
+void collectFdWakeup(int wakeup_fd_r)
+{
+ int res;
+#if defined(HAVE_EVENTFD)
+ uint64_t buf;
+ /* eventfd combines events into one counter, so a single read is enough */
+ res = read(wakeup_fd_r, &buf, 8);
+#else
+ /* Drain the pipe buffer. Multiple wakeup notifications could
+ * have been sent before we have a chance to collect them.
+ */
+ uint64_t buf;
+ do {
+ res = read(wakeup_fd_r, &buf, 8);
+ } while (res == 8);
+#endif
+ if (RTS_UNLIKELY(res < 0)) {
+ /* After the first pipe read, it could block */
+ if (errno == EAGAIN) return;
+ sysErrorBelch("collectFdWakeup read");
+ stg_exit(EXIT_FAILURE);
+ }
+}
=====================================
rts/posix/FdWakeup.h
=====================================
@@ -0,0 +1,40 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2025
+ *
+ * Utilities for a simple fd-based cross-thread wakeup mechanism.
+ *
+ * It provides a mechanism for a thread that block on fds to add a simple
+ * wakeup/notification feature.
+ *
+ * Start with newFdWakeup, and pass the fd_r to the thread that needs the
+ * wakeup feature. The thread that needs to be woken should include the fd_r
+ * into the set of fds that the thread waits on (e.g. using poll or similar).
+ * If this fd becomes ready for read, the thread must call collectFdWakeup,
+ * and when a wake up is needed, the write end fd is used. In any other thread
+ * (or in a signal handler), call sendFdWakeup(fd_w) to (asynchronously) cause
+ * the wakeup.
+ *
+ * There is no message payload. Multiple wakeups may be combined (if they're
+ * sent multiple times before the notified thread can wake and call
+ * collectFdWakeup).
+ *
+ * The implementation uses pipe() or eventfd() on supported OSs.
+ *
+ * Prototypes for functions in FdWakeup.c
+ *
+ * -------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "BeginPrivate.h"
+
+void newFdWakeup(int *fd_r, int *fd_w);
+void closeFdWakeup(int fd_r, int fd_w);
+
+/* This is safe to use from a signal handler */
+void sendFdWakeup(int fd_w);
+void collectFdWakeup(int fd_r);
+
+#include "EndPrivate.h"
+
=====================================
rts/posix/Ticker.c
=====================================
@@ -1,19 +1,53 @@
/* -----------------------------------------------------------------------------
*
- * (c) The GHC Team, 1995-2007
+ * (c) The GHC Team, 1995-2026
*
- * Posix implementation(s) of the interval timer for profiling and pre-emptive
- * scheduling.
+ * The posix implementation of the interval timer, used for pre-emptive
+ * scheduling of Haskell threads, and for sample based profiling.
+ *
+ * This file defines the "ticker": the platform-specific service to install and
+ * run the timer. See rts/Timer.c for the platform-dependent view of interval
+ * timing.
*
* ---------------------------------------------------------------------------*/
-/* The interval timer is used for profiling and for context switching.
- * This file defines the platform-specific services to install and run the
- * timers, and we call this the ticker. See rts/Timer.c for the
- * platform-dependent view of interval timing.
+/* This implementation uses a posix thread which repeatedly blocks on a timeout
+ * using either the ppoll() or select() API. This lets it also block on a file
+ * descriptor for early wakeup.
+ *
+ * The design uses a simple relative time delay with no catchup. That is, time
+ * spent by the ticker thread itself (e.g. flushing eventlog buffers) is not
+ * accounted for, and the next tick is delayed by that much (modulo wakeup
+ * jitter). This is probably the right thing to do: generally in realtime
+ * systems one does not want to try to catch up when behind, since that tends
+ * towards oversubscribing resources. Graceful degredation is usually
+ * preferable.
+ *
+ * Experimental results (on Linux 6.18 on x86-64) to measure the typical
+ * difference between the requested wakeup time and actual wakeup time for
+ * different delay intervals:
+ *
+ * interval typical actual wakeup time after due time
+ * 10000us 340 -- 400us (this is the default interval)
+ * 1000us 55 -- 100us
+ * 100us 55us
+ * 10us 55us
+ *
+ * While there's quite a bit of variance to these numbers, the results do not
+ * vary significantly between using select, ppoll or nanosleep.
+ *
+ * On Linux at least, for longer delays the kernel allows itself lower wakeup
+ * accuracy (which allows it to save power by coalescing multiple wakeups).
+ * Similarly, the reason for 55us on the low end is that the default thread
+ * timer slack on Linux is 50us, and context switch time accounts for the
+ * remainder.
+ *
+ * In conclusion, on Linux at least, the accuracy is fine, both for the
+ * default interval (10ms, 10000us) and for shorter intervals used during
+ * profiling.
*
* Historically we had ticker implementations using signals. This was always a
- * rather shakey thing to do but we had few alternatives.
+ * rather shakey thing to do but we originally had few alternatives.
* - One problem with using signals is that there are severe limits on what
* code can be called from signal handlers. In particular it's not possible
* to take locks in a signal handler contex. This was enough for contex
@@ -23,17 +57,245 @@
* calls (#10840) or can be overwritten by user code.
*/
-/* Select a ticker implementation to use:
- *
- * On modern Linux, FreeBSD and NetBSD we can use timerfd_create and a thread
- * that waits on it using poll. Linux has had timerfd since version 2.6.25.
- * NetBSD has had timerfd since version 10, and FreeBSD since version 15.
- *
- * For older version of linux/bsd without timerfd, and for all other posix
- * platforms, we use the implementation using posix pthreads and nanosleep().
+#include "rts/PosixSource.h"
+#include "Rts.h"
+
+#include "Ticker.h"
+#include "RtsUtils.h"
+#include "Proftimer.h"
+#include "Schedule.h"
+#include "posix/Clock.h"
+#include "posix/FdWakeup.h"
+
+#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1
+/* We prefer the ppoll() function if available since it allows sanely waiting
+ * on a single fd with precise timeouts (nanosecond precision). It is not in
+ * the posix standard however and some platforms (notably glibc and freebsd)
+ * need special CPP defines to make it available:
+ */
+#define _GNU_SOURCE 1
+#define __BSD_VISIBLE 1
+#include <signal.h>
+#include <poll.h>
+#else
+/* Otherwise we use the classic select(), which does have microsecond
+ * precision, but requires we build three whole 1024 bit (128 byte) fd sets
+ * just to wait on one fd.
*/
-#if defined(HAVE_SYS_TIMERFD_H)
-#include "ticker/TimerFd.c"
+#include <sys/select.h>
+#endif
+
+#include <time.h>
+#if HAVE_SYS_TIME_H
+# include <sys/time.h>
+#endif
+
+#if defined(HAVE_SIGNAL_H)
+# include <signal.h>
+#endif
+
+#include <string.h>
+
+#include <pthread.h>
+#if defined(HAVE_PTHREAD_NP_H)
+#include <pthread_np.h>
+#endif
+#include <unistd.h>
+#include <fcntl.h>
+
+static Time itimer_interval = DEFAULT_TICK_INTERVAL;
+
+// Should we be firing ticks?
+// Writers to this must hold the mutex below.
+static bool stopped = false;
+
+// should the ticker thread exit?
+// This can be set without holding the mutex.
+static bool exited = true;
+
+// Signaled when we want to (re)start the timer
+static Condition start_cond;
+static Mutex mutex;
+static OSThreadId thread;
+
+// fds for interrupting the ticker
+static int interruptfd_r = -1, interruptfd_w = -1;
+
+static void *itimer_thread_func(void *_handle_tick)
+{
+ TickProc handle_tick = _handle_tick;
+
+#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1
+ struct pollfd pollfds[1];
+
+ pollfds[0].fd = interruptfd_r;
+ pollfds[0].events = POLLIN;
+
+ struct timespec ts = { .tv_sec = TimeToSeconds(itimer_interval)
+ , .tv_nsec = TimeToNS(itimer_interval) % 1000000000
+ };
#else
-#include "ticker/Pthread.c"
+ fd_set selectfds;
+ FD_ZERO(&selectfds);
+ FD_SET(interruptfd_r, &selectfds);
+
+ struct timeval tv = { .tv_sec = TimeToSeconds(itimer_interval)
+ /* convert remainder time in nanoseconds
+ to microseconds, rounding up: */
+ , .tv_usec = ((TimeToNS(itimer_interval) % 1000000000)
+ + 999) / 1000
+ };
+#endif
+
+ // Relaxed is sufficient: If we don't see that exited was set in one iteration we will
+ // see it next time.
+ while (!RELAXED_LOAD_ALWAYS(&exited)) {
+
+#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1
+ int nfds = 1;
+ int nready = ppoll(pollfds, nfds, &ts, NULL);
+#else
+ struct timeval tv_tmp = tv; // copy since select may change this value.
+ int nfds = interruptfd_r+1;
+ int nready = select(nfds, &selectfds, NULL, NULL, &tv_tmp);
+#endif
+ // In either case (ppoll or select), the result nready is the number
+ // of fds that are ready.
+ if (RTS_LIKELY(nready == 0)) {
+ // Timer expired, not interrupted, continue.
+ } else if (nready > 0) {
+ // We only monitor one fd (the interruptfd_r), so we know
+ // it is that fd that is ready without any further checks.
+ collectFdWakeup(interruptfd_r);
+ // No further action needed, continue on to handling the final tick
+ // and then stop.
+
+ // Note that we rely on sendFdWakeup and select/poll to provide the
+ // happens-before relation. So if 'exited' was set before calling
+ // sendFdWakeup, then we should be able to reliably read it after.
+ // And thus reading 'exited' in the while loop guard is ok.
+ } else {
+ // While the RTS attempts to mask signals, some foreign libraries
+ // that rely on signal delivery may unmask them. Consequently we
+ // may see EINTR. See #24610.
+ if (errno != EINTR) {
+ sysErrorBelch("Ticker: poll failed: %s", strerror(errno));
+ }
+ }
+
+ // first try a cheap test
+ if (RELAXED_LOAD_ALWAYS(&stopped)) {
+ OS_ACQUIRE_LOCK(&mutex);
+ // should we really stop?
+ if (stopped) {
+ waitCondition(&start_cond, &mutex);
+ }
+ OS_RELEASE_LOCK(&mutex);
+ } else {
+ handle_tick(0);
+ }
+ }
+
+ return NULL;
+}
+
+void
+initTicker (Time interval, TickProc handle_tick)
+{
+ itimer_interval = interval;
+ stopped = true;
+ exited = false;
+#if defined(HAVE_SIGNAL_H)
+ sigset_t mask, omask;
+ int sigret;
+#endif
+ int ret;
+
+ initCondition(&start_cond);
+ initMutex(&mutex);
+
+ /* Open the interrupt fd synchronously.
+ *
+ * We used to do it in itimer_thread_func (i.e. in the timer thread) but it
+ * meant that some user code could run before it and get confused by the
+ * allocation of the timerfd.
+ *
+ * See hClose002 which unsafely closes a file descriptor twice expecting an
+ * exception the second time: it sometimes failed when the second call to
+ * "close" closed our own timerfd which inadvertently reused the same file
+ * descriptor closed by the first call! (see #20618)
+ */
+
+ if (interruptfd_r != -1) {
+ // don't leak the old file descriptors after a fork (#25280)
+ closeFdWakeup(interruptfd_r, interruptfd_w);
+ }
+ newFdWakeup(&interruptfd_r, &interruptfd_w);
+
+ /*
+ * Create the thread with all blockable signals blocked, leaving signal
+ * handling to the main and/or other threads. This is especially useful in
+ * the non-threaded runtime, where applications might expect sigprocmask(2)
+ * to effectively block signals.
+ */
+#if defined(HAVE_SIGNAL_H)
+ sigfillset(&mask);
+ sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask);
+#endif
+ ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick);
+#if defined(HAVE_SIGNAL_H)
+ if (sigret == 0)
+ pthread_sigmask(SIG_SETMASK, &omask, NULL);
#endif
+
+ if (ret != 0) {
+ barf("Ticker: Failed to spawn thread: %s", strerror(errno));
+ }
+}
+
+void
+startTicker(void)
+{
+ OS_ACQUIRE_LOCK(&mutex);
+ RELAXED_STORE(&stopped, false);
+ signalCondition(&start_cond);
+ OS_RELEASE_LOCK(&mutex);
+}
+
+/* There may be at most one additional tick fired after a call to this */
+void
+stopTicker(void)
+{
+ OS_ACQUIRE_LOCK(&mutex);
+ RELAXED_STORE(&stopped, true);
+ OS_RELEASE_LOCK(&mutex);
+}
+
+/* There may be at most one additional tick fired after a call to this */
+void
+exitTicker (bool wait)
+{
+ ASSERT(!SEQ_CST_LOAD(&exited));
+ SEQ_CST_STORE(&exited, true);
+ // ensure that ticker wakes up if stopped
+ startTicker();
+ sendFdWakeup(interruptfd_w);
+
+ // wait for ticker to terminate if necessary
+ if (wait) {
+ if (pthread_join(thread, NULL)) {
+ sysErrorBelch("Ticker: Failed to join: %s", strerror(errno));
+ }
+ closeFdWakeup(interruptfd_r, interruptfd_w);
+ closeMutex(&mutex);
+ closeCondition(&start_cond);
+ } else {
+ pthread_detach(thread);
+ }
+}
+
+int
+rtsTimerSignal(void)
+{
+ return SIGALRM;
+}
=====================================
rts/posix/ticker/Pthread.c deleted
=====================================
@@ -1,195 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * (c) The GHC Team, 1995-2007
- *
- * Interval timer for profiling and pre-emptive scheduling.
- *
- * ---------------------------------------------------------------------------*/
-
-/*
- * We use a realtime timer by default. I found this much more
- * reliable than a CPU timer:
- *
- * Experiments with different frequencies: using
- * CLOCK_REALTIME/CLOCK_MONOTONIC on Linux 2.6.32,
- * 1000us has <1% impact on runtime
- * 100us has ~2% impact on runtime
- * 10us has ~40% impact on runtime
- *
- * using CLOCK_PROCESS_CPUTIME_ID on Linux 2.6.32,
- * I cannot get it to tick faster than 10ms (10000us)
- * which isn't great for profiling.
- *
- * In the threaded RTS, we can't tick in CPU time because the thread
- * which has the virtual timer might be idle, so the tick would never
- * fire. Therefore we used to tick in realtime in the threaded RTS and
- * in CPU time otherwise, but now we always tick in realtime, for
- * several reasons:
- *
- * - resolution (see above)
- * - consistency (-threaded is the same as normal)
- * - more consistency: Windows only has a realtime timer
- *
- * Note we want to use CLOCK_MONOTONIC rather than CLOCK_REALTIME,
- * because the latter may jump around (NTP adjustments, leap seconds
- * etc.).
- */
-
-#include "rts/PosixSource.h"
-#include "Rts.h"
-
-#include "Ticker.h"
-#include "RtsUtils.h"
-#include "Proftimer.h"
-#include "Schedule.h"
-#include "posix/Clock.h"
-#include <poll.h>
-
-#include <time.h>
-#if HAVE_SYS_TIME_H
-# include <sys/time.h>
-#endif
-
-#if defined(HAVE_SIGNAL_H)
-# include <signal.h>
-#endif
-
-#include <string.h>
-
-#include <pthread.h>
-#if defined(HAVE_PTHREAD_NP_H)
-#include <pthread_np.h>
-#endif
-#include <unistd.h>
-#include <fcntl.h>
-
-/*
- * TFD_CLOEXEC has been added in Linux 2.6.26.
- * If it is not available, we use fcntl(F_SETFD).
- */
-#if !defined(TFD_CLOEXEC)
-#define TFD_CLOEXEC 0
-#endif
-
-static Time itimer_interval = DEFAULT_TICK_INTERVAL;
-
-// Should we be firing ticks?
-// Writers to this must hold the mutex below.
-static bool stopped = false;
-
-// should the ticker thread exit?
-// This can be set without holding the mutex.
-static bool exited = true;
-
-// Signaled when we want to (re)start the timer
-static Condition start_cond;
-static Mutex mutex;
-static OSThreadId thread;
-
-static void *itimer_thread_func(void *_handle_tick)
-{
- TickProc handle_tick = _handle_tick;
-
- // Relaxed is sufficient: If we don't see that exited was set in one iteration we will
- // see it next time.
- while (!RELAXED_LOAD_ALWAYS(&exited)) {
- if (rtsSleep(itimer_interval) != 0) {
- sysErrorBelch("Ticker: sleep failed: %s", strerror(errno));
- }
-
- // first try a cheap test
- if (RELAXED_LOAD_ALWAYS(&stopped)) {
- OS_ACQUIRE_LOCK(&mutex);
- // should we really stop?
- if (stopped) {
- waitCondition(&start_cond, &mutex);
- }
- OS_RELEASE_LOCK(&mutex);
- } else {
- handle_tick(0);
- }
- }
-
- return NULL;
-}
-
-void
-initTicker (Time interval, TickProc handle_tick)
-{
- itimer_interval = interval;
- stopped = true;
- exited = false;
-#if defined(HAVE_SIGNAL_H)
- sigset_t mask, omask;
- int sigret;
-#endif
- int ret;
-
- initCondition(&start_cond);
- initMutex(&mutex);
-
- /*
- * Create the thread with all blockable signals blocked, leaving signal
- * handling to the main and/or other threads. This is especially useful in
- * the non-threaded runtime, where applications might expect sigprocmask(2)
- * to effectively block signals.
- */
-#if defined(HAVE_SIGNAL_H)
- sigfillset(&mask);
- sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask);
-#endif
- ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick);
-#if defined(HAVE_SIGNAL_H)
- if (sigret == 0)
- pthread_sigmask(SIG_SETMASK, &omask, NULL);
-#endif
-
- if (ret != 0) {
- barf("Ticker: Failed to spawn thread: %s", strerror(errno));
- }
-}
-
-void
-startTicker(void)
-{
- OS_ACQUIRE_LOCK(&mutex);
- RELAXED_STORE(&stopped, false);
- signalCondition(&start_cond);
- OS_RELEASE_LOCK(&mutex);
-}
-
-/* There may be at most one additional tick fired after a call to this */
-void
-stopTicker(void)
-{
- OS_ACQUIRE_LOCK(&mutex);
- RELAXED_STORE(&stopped, true);
- OS_RELEASE_LOCK(&mutex);
-}
-
-/* There may be at most one additional tick fired after a call to this */
-void
-exitTicker (bool wait)
-{
- ASSERT(!SEQ_CST_LOAD(&exited));
- SEQ_CST_STORE(&exited, true);
- // ensure that ticker wakes up if stopped
- startTicker();
-
- // wait for ticker to terminate if necessary
- if (wait) {
- if (pthread_join(thread, NULL)) {
- sysErrorBelch("Ticker: Failed to join: %s", strerror(errno));
- }
- closeMutex(&mutex);
- closeCondition(&start_cond);
- } else {
- pthread_detach(thread);
- }
-}
-
-int
-rtsTimerSignal(void)
-{
- return SIGALRM;
-}
=====================================
rts/posix/ticker/TimerFd.c deleted
=====================================
@@ -1,291 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * (c) The GHC Team, 1995-2023
- *
- * Interval timer for profiling and pre-emptive scheduling.
- *
- * ---------------------------------------------------------------------------*/
-
-/*
- * We use a realtime timer by default. I found this much more
- * reliable than a CPU timer:
- *
- * Experiments with different frequencies: using
- * CLOCK_REALTIME/CLOCK_MONOTONIC on Linux 2.6.32,
- * 1000us has <1% impact on runtime
- * 100us has ~2% impact on runtime
- * 10us has ~40% impact on runtime
- *
- * using CLOCK_PROCESS_CPUTIME_ID on Linux 2.6.32,
- * I cannot get it to tick faster than 10ms (10000us)
- * which isn't great for profiling.
- *
- * In the threaded RTS, we can't tick in CPU time because the thread
- * which has the virtual timer might be idle, so the tick would never
- * fire. Therefore we used to tick in realtime in the threaded RTS and
- * in CPU time otherwise, but now we always tick in realtime, for
- * several reasons:
- *
- * - resolution (see above)
- * - consistency (-threaded is the same as normal)
- * - more consistency: Windows only has a realtime timer
- *
- * Note we want to use CLOCK_MONOTONIC rather than CLOCK_REALTIME,
- * because the latter may jump around (NTP adjustments, leap seconds
- * etc.).
- */
-
-#include "rts/PosixSource.h"
-#include "Rts.h"
-
-#include "Ticker.h"
-#include "RtsUtils.h"
-#include "Proftimer.h"
-#include "Schedule.h"
-#include "posix/Clock.h"
-#include <poll.h>
-
-#include <time.h>
-#if HAVE_SYS_TIME_H
-# include <sys/time.h>
-#endif
-
-#if defined(HAVE_SIGNAL_H)
-# include <signal.h>
-#endif
-
-#include <string.h>
-
-#include <pthread.h>
-#if defined(HAVE_PTHREAD_NP_H)
-#include <pthread_np.h>
-#endif
-#include <unistd.h>
-#include <fcntl.h>
-
-#include <sys/timerfd.h>
-
-
-/*
- * TFD_CLOEXEC has been added in Linux 2.6.26.
- * If it is not available, we use fcntl(F_SETFD).
- */
-#if !defined(TFD_CLOEXEC)
-#define TFD_CLOEXEC 0
-#endif
-
-static Time itimer_interval = DEFAULT_TICK_INTERVAL;
-
-// Should we be firing ticks?
-// Writers to this must hold the mutex below.
-static bool stopped = false;
-
-// should the ticker thread exit?
-// This can be set without holding the mutex.
-static bool exited = true;
-
-// Signaled when we want to (re)start the timer
-static Condition start_cond;
-static Mutex mutex;
-static OSThreadId thread;
-
-// file descriptor for the timer (Linux only)
-static int timerfd = -1;
-
-// pipe for signaling exit
-static int pipefds[2];
-
-static void *itimer_thread_func(void *_handle_tick)
-{
- TickProc handle_tick = _handle_tick;
- uint64_t nticks;
- ssize_t r = 0;
- struct pollfd pollfds[2];
-
- pollfds[0].fd = pipefds[0];
- pollfds[0].events = POLLIN;
- pollfds[1].fd = timerfd;
- pollfds[1].events = POLLIN;
-
- // Relaxed is sufficient: If we don't see that exited was set in one iteration we will
- // see it next time.
- while (!RELAXED_LOAD_ALWAYS(&exited)) {
- if (poll(pollfds, 2, -1) == -1) {
- // While the RTS attempts to mask signals, some foreign libraries
- // may rely on signal delivery may unmask them. Consequently we may
- // see EINTR. See #24610.
- if (errno != EINTR) {
- sysErrorBelch("Ticker: poll failed: %s", strerror(errno));
- }
- }
-
- // We check the pipe first, even though the timerfd may also have triggered.
- if (pollfds[0].revents & POLLIN) {
- // the pipe is ready for reading, the only possible reason is that we're exiting
- exited = true; // set this again to make sure even RELAXED_LOAD will read the proper value
- // no further action needed, skip ahead to handling the final tick and then stopping
- }
- else if (pollfds[1].revents & POLLIN) { // the timerfd is ready for reading
- r = read(timerfd, &nticks, sizeof(nticks)); // this should never block now
-
- if ((r == 0) && (errno == 0)) {
- /* r == 0 is expected only for non-blocking fd (in which case
- * errno should be EAGAIN) but we use a blocking fd.
- *
- * Due to a kernel bug (cf https://lkml.org/lkml/2019/8/16/335)
- * on some platforms we could see r == 0 and errno == 0.
- */
- IF_DEBUG(scheduler, debugBelch("read(timerfd) returned 0 with errno=0. This is a known kernel bug. We just ignore it."));
- }
- else if (r != sizeof(nticks) && errno != EINTR) {
- barf("Ticker: read(timerfd) failed with %s and returned %zd", strerror(errno), r);
- }
- }
-
- // first try a cheap test
- if (RELAXED_LOAD_ALWAYS(&stopped)) {
- OS_ACQUIRE_LOCK(&mutex);
- // should we really stop?
- if (stopped) {
- waitCondition(&start_cond, &mutex);
- }
- OS_RELEASE_LOCK(&mutex);
- } else {
- handle_tick(0);
- }
- }
-
- close(timerfd);
- return NULL;
-}
-
-void
-initTicker (Time interval, TickProc handle_tick)
-{
- itimer_interval = interval;
- stopped = true;
- exited = false;
-#if defined(HAVE_SIGNAL_H)
- sigset_t mask, omask;
- int sigret;
-#endif
- int ret;
-
- initCondition(&start_cond);
- initMutex(&mutex);
-
- /* Open the file descriptor for the timer synchronously.
- *
- * We used to do it in itimer_thread_func (i.e. in the timer thread) but it
- * meant that some user code could run before it and get confused by the
- * allocation of the timerfd.
- *
- * See hClose002 which unsafely closes a file descriptor twice expecting an
- * exception the second time: it sometimes failed when the second call to
- * "close" closed our own timerfd which inadvertently reused the same file
- * descriptor closed by the first call! (see #20618)
- */
- struct itimerspec it;
- it.it_value.tv_sec = TimeToSeconds(itimer_interval);
- it.it_value.tv_nsec = TimeToNS(itimer_interval) % 1000000000;
- it.it_interval = it.it_value;
-
- if (timerfd != -1) {
- // don't leak the old file descriptors after a fork (#25280)
- close(timerfd);
- close(pipefds[0]);
- close(pipefds[1]);
- timerfd = -1;
- }
-
- timerfd = timerfd_create(CLOCK_MONOTONIC, TFD_CLOEXEC);
- if (timerfd == -1) {
- barf("timerfd_create: %s", strerror(errno));
- }
- if (!TFD_CLOEXEC) {
- fcntl(timerfd, F_SETFD, FD_CLOEXEC);
- }
- if (timerfd_settime(timerfd, 0, &it, NULL)) {
- barf("timerfd_settime: %s", strerror(errno));
- }
-
- if (pipe(pipefds) < 0) {
- barf("pipe: %s", strerror(errno));
- }
-
- /*
- * Create the thread with all blockable signals blocked, leaving signal
- * handling to the main and/or other threads. This is especially useful in
- * the non-threaded runtime, where applications might expect sigprocmask(2)
- * to effectively block signals.
- */
-#if defined(HAVE_SIGNAL_H)
- sigfillset(&mask);
- sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask);
-#endif
- ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick);
-#if defined(HAVE_SIGNAL_H)
- if (sigret == 0)
- pthread_sigmask(SIG_SETMASK, &omask, NULL);
-#endif
-
- if (ret != 0) {
- barf("Ticker: Failed to spawn thread: %s", strerror(errno));
- }
-}
-
-void
-startTicker(void)
-{
- OS_ACQUIRE_LOCK(&mutex);
- RELAXED_STORE(&stopped, false);
- signalCondition(&start_cond);
- OS_RELEASE_LOCK(&mutex);
-}
-
-/* There may be at most one additional tick fired after a call to this */
-void
-stopTicker(void)
-{
- OS_ACQUIRE_LOCK(&mutex);
- RELAXED_STORE(&stopped, true);
- OS_RELEASE_LOCK(&mutex);
-}
-
-/* There may be at most one additional tick fired after a call to this */
-void
-exitTicker (bool wait)
-{
- ASSERT(!SEQ_CST_LOAD(&exited));
- SEQ_CST_STORE(&exited, true);
- // ensure that ticker wakes up if stopped
- startTicker();
-
- // wait for ticker to terminate if necessary
- if (wait) {
- // write anything to the pipe to trigger poll() in the ticker thread
- if (write(pipefds[1], "stop", 5) < 0) {
- sysErrorBelch("Ticker: Failed to write to pipe: %s", strerror(errno));
- }
-
- if (pthread_join(thread, NULL)) {
- sysErrorBelch("Ticker: Failed to join: %s", strerror(errno));
- }
-
- // These need to happen AFTER the ticker thread has finished to prevent a race condition
- // where the ticker thread closes the read end of the pipe before we're done writing to it.
- close(pipefds[0]);
- close(pipefds[1]);
-
- closeMutex(&mutex);
- closeCondition(&start_cond);
- } else {
- pthread_detach(thread);
- }
-}
-
-int
-rtsTimerSignal(void)
-{
- return SIGALRM;
-}
=====================================
rts/rts.cabal
=====================================
@@ -582,11 +582,9 @@ library
posix/Ticker.c
posix/OSMem.c
posix/OSThreads.c
+ posix/FdWakeup.c
posix/Poll.c
posix/Select.c
posix/Signals.c
posix/Timeout.c
posix/TTY.c
- -- ticker/*.c
- -- We don't want to compile posix/ticker/*.c, these will be #included
- -- from Ticker.c
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/84c751d4b93c44f99ddea53236f23b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/84c751d4b93c44f99ddea53236f23b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/dcoutts/windows-dlls-experimental
by Duncan Coutts (＠dcoutts) 07 Apr '26
by Duncan Coutts (＠dcoutts) 07 Apr '26
07 Apr '26
Duncan Coutts pushed new branch wip/dcoutts/windows-dlls-experimental at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/dcoutts/windows-dlls-experime…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/hpc-bc-support] fixup! Add more tests for ghci and -fhpc
by Hannes Siebenhandl (＠fendor) 07 Apr '26
by Hannes Siebenhandl (＠fendor) 07 Apr '26
07 Apr '26
Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC
Commits:
94b3f5bf by fendor at 2026-04-07T11:11:54+02:00
fixup! Add more tests for ghci and -fhpc
- - - - -
2 changed files:
- testsuite/tests/hpc/function/test.T
- testsuite/tests/hpc/simple/test.T
Changes:
=====================================
testsuite/tests/hpc/function/test.T
=====================================
@@ -3,7 +3,7 @@ setTestOpts([when(fast(), skip), js_skip])
hpc_prefix = "./hpcrun.sh --clear --exeext={exeext} --hpc={hpc} --"
test('tough',
- [extra_files(['../hpcrun.pl']),
+ [extra_files(['hpcrun.sh']),
cmd_prefix(hpc_prefix),
ignore_extension,
when(arch('wasm32'), fragile(23243))],
=====================================
testsuite/tests/hpc/simple/test.T
=====================================
@@ -1,4 +1,4 @@
-setTestOpts([omit_ghci, when(fast(), skip), js_skip])
+setTestOpts([when(fast(), skip), js_skip])
hpc_prefix = "perl hpcrun.pl --clear --exeext={exeext} --hpc={hpc}"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/94b3f5bfde4590e608bc3083536d41a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/94b3f5bfde4590e608bc3083536d41a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/ghci-messages-no-string] 4 commits: base: improve error message for Data.Char.chr
by Cheng Shao (＠TerrorJack) 07 Apr '26
by Cheng Shao (＠TerrorJack) 07 Apr '26
07 Apr '26
Cheng Shao pushed to branch wip/ghci-messages-no-string at Glasgow Haskell Compiler / GHC
Commits:
502e6ffe by Andrew Lelechenko at 2026-04-07T04:47:21-04:00
base: improve error message for Data.Char.chr
As per https://github.com/haskell/core-libraries-committee/issues/384
- - - - -
b21bd52e by Simon Peyton Jones at 2026-04-07T04:48:07-04:00
Refactor FunResCtxt a bit
Fixes #27154
- - - - -
4b999500 by Cheng Shao at 2026-04-07T08:57:36+00:00
ghci: use ShortByteString for LookupSymbol/LookupSymbolInDLL/LookupClosure messages
This patch refactors ghci to use `ShortByteString` for
`LookupSymbol`/`LookupSymbolInDLL`/`LookupClosure` messages as the
first part of #27147.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
475642de by Cheng Shao at 2026-04-07T08:57:39+00:00
ghci: use ShortByteString for MkCostCentres message
This patch refactors ghci to use `ShortByteString` for `MkCostCentres`
messages as a first part of #27147. This also considerably lowers the
memory overhead of breakpoints when cost center profiling is enabled.
-------------------------
Metric Decrease:
interpreter_steplocal
-------------------------
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
22 changed files:
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- libraries/base/changelog.md
- libraries/base/tests/enum01.stdout
- libraries/base/tests/enum01.stdout-alpha-dec-osf3
- libraries/base/tests/enum01.stdout-ws-64
- libraries/ghc-internal/src/GHC/Internal/Char.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/ObjLink.hs
- libraries/ghci/GHCi/Run.hs
- testsuite/tests/driver/linkwhole/Main.hs
- testsuite/tests/ghci/should_run/T18064.script
- testsuite/tests/rts/KeepCafsMain.hs
- utils/jsffi/dyld.mjs
Changes:
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.Name.Occurrence
import Control.DeepSeq
+import qualified Data.ByteString.Short as SBS
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
@@ -235,8 +236,8 @@ getBreakVars = getBreakXXX modBreaks_vars
getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]
getBreakDecls = getBreakXXX modBreaks_decls
--- | Get the decls for this breakpoint
-getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String))
+-- | Get the cost centre info for this breakpoint
+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (SBS.ShortByteString, SBS.ShortByteString)
getBreakCCS = getBreakXXX modBreaks_ccs
-- | Internal utility to access a ModBreaks field at a particular breakpoint index
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -405,7 +405,7 @@ loadExternalPlugins ps = do
symbol
| null unit = ztmp
| otherwise = zEncodeString unit ++ "_" ++ ztmp
- plugin <- lookupSymbol symbol >>= \case
+ plugin <- lookupSymbol (utf8EncodeShortByteString symbol) >>= \case
Nothing -> pprPanic "loadExternalPlugins"
(vcat [ text "Symbol not found"
, text " Library path: " <> text path
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.HsToCore.Breakpoints
import GHC.Prelude
import Data.Array
+import qualified Data.ByteString.Short as SBS
import GHC.HsToCore.Ticks (Tick (..))
import GHC.Data.SizedSeq
@@ -31,6 +32,7 @@ import GHC.Types.Name (OccName)
import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..))
import GHC.Unit.Module (Module)
import GHC.Utils.Binary
+import GHC.Utils.Encoding (utf8EncodeShortByteString)
import GHC.Utils.Outputable
import Data.List (intersperse)
import Data.Coerce
@@ -59,7 +61,7 @@ data ModBreaks
, modBreaks_decls :: !(Array BreakTickIndex [String])
-- ^ An array giving the names of the declarations enclosing each breakpoint.
-- See Note [Field modBreaks_decls]
- , modBreaks_ccs :: !(Array BreakTickIndex (String, String))
+ , modBreaks_ccs :: !(Array BreakTickIndex (SBS.ShortByteString, SBS.ShortByteString))
-- ^ Array pointing to cost centre info for each breakpoint;
-- actual 'CostCentre' allocation is done at link-time.
, modBreaks_module :: !Module
@@ -89,8 +91,8 @@ mkModBreaks interpreterProfiled modl extendedMixEntries
| interpreterProfiled =
listArray
(0, count - 1)
- [ ( concat $ intersperse "." $ tick_path t,
- renderWithContext defaultSDocContext $ ppr $ tick_loc t
+ [ ( utf8EncodeShortByteString $ concat $ intersperse "." $ tick_path t,
+ utf8EncodeShortByteString $ renderWithContext defaultSDocContext $ ppr $ tick_loc t
)
| t <- entries
]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -1846,7 +1846,7 @@ allocateCCS interp ce mbss
ccs <- {- one ccs ptr per tick index -}
mkCostCentres
interp
- (moduleNameString $ moduleName modBreaks_module)
+ (moduleNameFS $ moduleName modBreaks_module)
(elems modBreaks_ccs)
return $ M.fromList $
zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..]
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -107,6 +107,7 @@ import Control.Monad.IO.Class
import Control.Monad.Catch as MC (mask)
import Data.Binary
import Data.ByteString (ByteString)
+import qualified Data.ByteString.Short as SBS
import Foreign hiding (void)
import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
@@ -352,9 +353,15 @@ evalStringToIOString interp fhv str =
mallocData :: Interp -> ByteString -> IO (RemotePtr ())
mallocData interp bs = interpCmd interp (MallocData bs)
-mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
-mkCostCentres interp mod ccs =
- interpCmd interp (MkCostCentres mod ccs)
+mkCostCentres :: Interp -> FastString -> [(SBS.ShortByteString, SBS.ShortByteString)] -> IO [RemotePtr CostCentre]
+mkCostCentres interp mod ccs = do
+ rp <- modifyMVar (interpStringCache interp) $ \fs_env ->
+ case lookupFsEnv fs_env mod of
+ Just rp -> pure (fs_env, rp)
+ Nothing -> do
+ rp <- fmap head $ interpCmd interp $ MallocStrings [bytesFS mod]
+ pure (extendFsEnv fs_env mod rp, rp)
+ interpCmd interp $ MkCostCentres rp ccs
-- | Create a set of BCOs that may be mutually recursive.
createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef]
@@ -413,7 +420,7 @@ evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
evalBreakpointToId eval_break =
let
mkUnitId u = fsToUnit $ mkFastStringShortByteString u
- toModule u n = mkModule (mkUnitId u) (mkModuleName n)
+ toModule u n = mkModule (mkUnitId u) (mkModuleNameFS (mkFastStringShortByteString n))
in
InternalBreakpointId
{ ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
@@ -465,27 +472,27 @@ lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbol interp str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbolInDLL interp dll str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
-- wasm dyld doesn't track which symbol comes from which .so
ExtWasm {} -> lookupSymbol interp str
@@ -519,7 +526,7 @@ interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is -
lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef)
lookupClosure interp str =
- interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str)))
+ interpCmd interp (LookupClosure (fastStringToShortByteString (interpSymbolToCLabel str)))
-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'
-- which maps symbols to the address where they are loaded.
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -7710,12 +7710,8 @@ pprHsCtxt = \case
PatSigErrCtxt sig_ty res_ty ->
vcat [ hang (text "When checking that the pattern signature:")
4 (ppr sig_ty)
- , nest 2 (hang (text "fits the type of its context:") 2 pp_res_ty) ]
- where
- -- Zonking will have turned Infer into Check
- pp_res_ty = case res_ty of
- Check ty -> ppr ty
- Infer ir -> text "OOPS" <+> ppr ir
+ , nest 2 (hang (text "fits the type of its context:")
+ 2 (ppr (getCheckExpType res_ty))) ]
PatCtxt pat ->
hang (text "In the pattern:") 2 (ppr pat)
@@ -7777,7 +7773,7 @@ pprHsCtxt = \case
full_herald = pprExpectedFunTyHerald herald
<+> speakNOf n_vis_args_in_call (text "visible argument")
-- What are "visible" arguments? See Note [Visibility and arity] in GHC.Types.Basic
- FunResCtxt fun n_val_args res_fun res_env n_fun n_env
+ FunResCtxt fun n_val_args fun_res_ty env_ty
| -- Check for too few args
-- fun_tau = a -> b, res_tau = Int
n_fun > n_env
@@ -7801,6 +7797,18 @@ pprHsCtxt = \case
-> empty
-- text "Debug" <+> vcat [ppr fun, ppr n_val_args, ppr res_fun, ppr res_env, ppr n_fun, ppr n_env]
where
+ -- See Note [Splitting nested sigma types in mismatched
+ -- function types]
+ -- env_ty is an ExpRhoTy, but with simple subsumption it
+ -- is not /deeply/ skolemised, so still use tcSplitNestedSigmaTys
+
+ (_,_,fun_tau) = tcSplitNestedSigmaTys fun_res_ty
+ (_, _, env_tau) = tcSplitNestedSigmaTys (getCheckExpType env_ty)
+ (args_fun, res_fun) = tcSplitFunTys fun_tau
+ (args_env, res_env) = tcSplitFunTys env_tau
+ n_fun = length args_fun
+ n_env = length args_env
+
not_fun ty -- ty is definitely not an arrow type,
-- and cannot conceivably become one
= case tcSplitTyConApp_maybe ty of
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -68,7 +68,6 @@ import GHC.Builtin.Names
import GHC.Driver.DynFlags
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
import GHC.Data.Maybe
@@ -961,7 +960,8 @@ See Note [-fno-code mode].
* *
********************************************************************* -}
-addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p]
+addFunResCtxt :: HasDebugCallStack
+ => HsExpr GhcTc -> [HsExprArg p]
-> TcType -> ExpRhoType
-> TcM a -> TcM a
-- When we have a mis-match in the return type of a function
@@ -969,33 +969,10 @@ addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p]
-- But not in generated code, where we don't want
-- to mention internal (rebindable syntax) function names
addFunResCtxt fun args fun_res_ty env_ty thing_inside
- = do { env_tv <- newFlexiTyVarTy liftedTypeKind
- ; dumping <- doptM Opt_D_dump_tc_trace
- ; msg <- mk_msg dumping env_tv
- ; addErrCtxt msg thing_inside }
+ = addErrCtxt (FunResCtxt fun (count isValArg args) fun_res_ty env_ty) $
+ thing_inside
-- NB: use a landmark error context, so that an empty context
-- doesn't suppress some more useful context
- where
- mk_msg dumping env_tv
- = do { mb_env_ty <- readExpType_maybe env_ty
- -- by the time the message is rendered, the ExpType
- -- will be filled in (except if we're debugging)
- ; env' <- case mb_env_ty of
- Just env_ty -> return env_ty
- Nothing -> do { massert dumping; return env_tv }
- ; let -- See Note [Splitting nested sigma types in mismatched
- -- function types]
- (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res_ty
- (_, _, env_tau) = tcSplitNestedSigmaTys env'
- -- env_ty is an ExpRhoTy, but with simple subsumption it
- -- is not deeply skolemised, so still use tcSplitNestedSigmaTys
- (args_fun, res_fun) = tcSplitFunTys fun_tau
- (args_env, res_env) = tcSplitFunTys env_tau
- info =
- FunResCtxt fun (count isValArg args) res_fun res_env
- (length args_fun) (length args_env)
- ; return info }
-
{-
Note [Splitting nested sigma types in mismatched function types]
=====================================
compiler/GHC/Tc/Types/ErrCtxt.hs
=====================================
@@ -251,7 +251,10 @@ data HsCtxt
-- | In the instance type signature of a class method.
| MethSigCtxt !Name !TcType !TcType
-- | In a pattern type signature.
+
| PatSigErrCtxt !TcType !ExpType
+ -- ExpType: see Note [ExpType in HsCtxt]
+
-- | In a pattern.
| PatCtxt !(Pat GhcRn)
-- | In a pattern synonym declaration.
@@ -268,7 +271,10 @@ data HsCtxt
-- | In a function call.
| FunTysCtxt !ExpectedFunTyCtxt !Type !Int !Int
-- | In the result of a function call.
- | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int
+
+ | FunResCtxt !(HsExpr GhcTc) !Int !TcType !ExpType
+ -- ExpType: see Note [ExpType in HsCtxt]
+
-- | In the declaration of a type constructor.
| TyConDeclCtxt !Name !(TyConFlavour TyCon)
-- | In a type or data family instance (or default instance).
@@ -377,3 +383,14 @@ isHsCtxtLandmark (DerivBindCtxt{}) = True
isHsCtxtLandmark (FunResCtxt{}) = True
isHsCtxtLandmark (VDQWarningCtxt{}) = True
isHsCtxtLandmark _ = False
+
+{- Note [ExpType in HsCtxt]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A couple of HsCtxt constructors have ExpTypes in them. When zonking the
+Infer{} case we read the hole, which should be filled in by now, and zonk
+that type. Now we want to put it back: we use (Check ty') for this, so that
+clients of a zonked HsCtxt don't need to be monadic.
+
+Result: after zonking, these ExpTypes are always (Check ty). It woudl be nice
+to guarantee this statically, but it's hard to do so.
+-}
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -28,7 +28,7 @@ module GHC.Tc.Utils.TcType (
ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..),
ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR,
ExpRhoType, ExpRhoTypeFRR,
- mkCheckExpType,
+ mkCheckExpType, getCheckExpType,
checkingExpType_maybe, checkingExpType,
ExpPatType(..), mkCheckExpFunPatTy, mkInvisExpPatType,
@@ -440,11 +440,12 @@ data InferInstFlag -- Specifies whether the inference should return an uninstan
| IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top)
-- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole
- -- Typically used when inferring the type of an expression
+ -- Used only for view patterns; see Note [View patterns and polymorphism]
| IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption)
-- If DeepSubsumption is off, same as IIF_ShallowRho
-- If DeepSubsumption is on, instantiate deeply before filling the hole
+ -- Typically used when inferring the type of an expression
type ExpSigmaType = ExpType
type ExpRhoType = ExpType
@@ -490,6 +491,12 @@ instance Outputable InferResult where
mkCheckExpType :: TcType -> ExpType
mkCheckExpType = Check
+getCheckExpType :: HasDebugCallStack => ExpType -> TcType
+-- Expect a (Check ty).
+-- See Note [ExpType in HsCtxt] in GHC.Tc.Types.ErrCtxt
+getCheckExpType (Check ty) = ty
+getCheckExpType (Infer ir) = pprPanic "getCheckExpType" (ppr ir)
+
-- | Returns the expected type when in checking mode.
checkingExpType_maybe :: ExpType -> Maybe TcType
checkingExpType_maybe (Check ty) = Just ty
=====================================
compiler/GHC/Tc/Zonk/TcType.hs
=====================================
@@ -818,19 +818,26 @@ zonkTidyHsCtxt env e@(FunAppCtxt{}) = return (env, e)
zonkTidyHsCtxt env (FunTysCtxt ctxt ty i1 i2) = do
(env', ty') <- zonkTidyTcType env ty
return $ (env', FunTysCtxt ctxt ty' i1 i2)
-zonkTidyHsCtxt env (FunResCtxt e i1 ty1 ty2 i2 i3) = do
- (env', ty1') <- zonkTidyTcType env ty1
- (env', ty2') <- zonkTidyTcType env' ty2
- return $ (env', FunResCtxt e i1 ty1' ty2' i2 i3)
+zonkTidyHsCtxt env (FunResCtxt e n ty1 env_ty) = do
+ (env', ty1') <- zonkTidyTcType env ty1
+ (env', env_ty') <- zonkExpType env' env_ty
+ return $ (env', FunResCtxt e n ty1' env_ty')
zonkTidyHsCtxt env (PatSigErrCtxt sig_ty res_ty) = do
(env', sig_ty') <- zonkTidyTcType env sig_ty
- (env', res_ty') <-
- case res_ty of
- Check ty -> zonkTidyTcType env' ty
- Infer (IR {ir_ref = ref}) -> do -- inlining readExpTyp_maybe to avoid module dep loops
- mb_ty <- liftIO $ readIORef ref
- case mb_ty of
- Nothing -> error "zonkTidyHsCtxt PatSigErrCtxt"
- Just ty -> zonkTidyTcType env' ty
- return (env', PatSigErrCtxt sig_ty' (Check res_ty'))
+ (env', res_ty') <- zonkExpType env' res_ty
+ return (env', PatSigErrCtxt sig_ty' res_ty')
zonkTidyHsCtxt env p = return (env, p)
+
+zonkExpType :: TidyEnv -> ExpType -> ZonkM (TidyEnv, ExpType)
+-- Zonk Infer{} to Check. The hole should have been filled in by now
+zonkExpType env (Check ty)
+ = do { (env', ty') <- zonkTidyTcType env ty
+ ; return (env', Check ty') }
+zonkExpType env (Infer ir@(IR { ir_ref = ref }))
+ = do { -- inlining readExpTyp_maybe to avoid module dep loops
+ ; mb_ty <- liftIO $ readIORef ref
+ ; case mb_ty of
+ Nothing -> pprPanic "zonkTidyHsCtxt PatSigErrCtxt" (ppr ir)
+ Just ty -> do { (env', ty') <- zonkTidyTcType env ty
+ ; return (env', Check ty') } }
+
=====================================
libraries/base/changelog.md
=====================================
@@ -28,6 +28,7 @@
* Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387))
* Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371))
* Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397))
+ * Improve error message for `Data.Char.chr`. ([CLC Proposal #384](https://github.com/haskell/core-libraries-committee/issues/384))
## 4.22.0.0 *TBA*
* Shipped with GHC 9.14.1
=====================================
libraries/base/tests/enum01.stdout
=====================================
@@ -81,7 +81,7 @@ Testing Enum Char:
pred (maxBound::Char) = '\1114110'
pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument"
(map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111"
- (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument: (-2147483648)"
+ (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111: (-2147483648)"
(map fromEnum ['X',minBound,maxBound]) = [88,0,1114111]
(take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK"
(take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256"
=====================================
libraries/base/tests/enum01.stdout-alpha-dec-osf3
=====================================
@@ -65,7 +65,7 @@ Testing Enum Char:
pred (maxBound::Char) = '\1114110'
pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument"
(map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111"
- (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument"
+ (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111:"
(map fromEnum ['X',minBound,maxBound]) = [88,0,1114111]
(take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK"
(take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256"
=====================================
libraries/base/tests/enum01.stdout-ws-64
=====================================
@@ -81,7 +81,7 @@ Testing Enum Char:
pred (maxBound::Char) = '\1114110'
pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument"
(map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111"
- (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument: (-9223372036854775808)"
+ (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111: (-9223372036854775808)"
(map fromEnum ['X',minBound,maxBound]) = [88,0,1114111]
(take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK"
(take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256"
=====================================
libraries/ghc-internal/src/GHC/Internal/Char.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Internal.Char
import GHC.Internal.Classes (eqChar, neChar)
import GHC.Internal.Base (otherwise, (++))
-import GHC.Internal.Err (errorWithoutStackTrace)
+import GHC.Internal.Err (error)
import GHC.Internal.Show
import GHC.Internal.Prim (chr#, int2Word#, leWord#, Int#, Char#)
import GHC.Internal.Types (Char(..), Int(..), isTrue#)
@@ -29,4 +29,7 @@ safe_chr# i#
{-# NOINLINE chr_error #-}
chr_error :: Int# -> Char#
-chr_error i# = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) (I# i#) "")
+chr_error i# = error ("Data.Char.chr: argument outside Unicode range: 0..1114111: " ++ showSignedInt (I# 9#) (I# i#) "")
+-- It's not really "Data.Char", but we assume that
+-- the majority of users will import it from "base:Data.Char"
+-- and not from "ghc-internal:GHC.Internal.Char".
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -86,9 +86,9 @@ data Message a where
-- These all invoke the corresponding functions in the RTS Linker API.
InitLinker :: Message ()
- LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
- LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
- LookupClosure :: String -> Message (Maybe HValueRef)
+ LookupSymbol :: !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
+ LookupSymbolInDLL :: !(RemotePtr LoadedDLL) -> !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
+ LookupClosure :: !BS.ShortByteString -> Message (Maybe HValueRef)
LoadDLLs :: [String] -> Message (Either String [RemotePtr LoadedDLL])
LoadArchive :: String -> Message () -- error?
LoadObj :: String -> Message () -- error?
@@ -162,8 +162,8 @@ data Message a where
-- | Create a set of CostCentres with the same module name
MkCostCentres
- :: String -- module, RemotePtr so it can be shared
- -> [(String,String)] -- (name, SrcSpan)
+ :: !(RemotePtr ()) -- ModuleName
+ -> ![(BS.ShortByteString, BS.ShortByteString)] -- (name, SrcSpan)
-> Message [RemotePtr CostCentre]
-- | Show a 'CostCentreStack' as a @[String]@
@@ -430,7 +430,7 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_info_mod :: String -- ^ Breakpoint info module
+ { eb_info_mod :: !BS.ShortByteString -- ^ Breakpoint info module
, eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id
, eb_info_index :: Int -- ^ Breakpoint info index
}
=====================================
libraries/ghci/GHCi/ObjLink.hs
=====================================
@@ -31,6 +31,8 @@ import GHCi.RemoteTypes
import GHCi.Message (LoadedDLL)
import Control.Exception (throwIO, ErrorCall(..))
import Control.Monad ( when )
+import qualified Data.ByteString.Short as BS
+import Data.Char (ord)
import Data.Foldable
import Foreign.C
import Foreign.Marshal.Alloc ( alloca, free )
@@ -104,15 +106,15 @@ unloadObj f = throwIO $ ErrorCall $ "unloadObj: unsupported on wasm for " <> f
purgeObj :: String -> IO ()
purgeObj f = throwIO $ ErrorCall $ "purgeObj: unsupported on wasm for " <> f
-lookupSymbol :: String -> IO (Maybe (Ptr a))
-lookupSymbol sym = do
- r <- js_lookupSymbol $ toJSString sym
+lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
+lookupSymbol sym@(BS.SBS ba#) = do
+ r <- js_lookupSymbolPtr ba# (BS.length sym)
evaluate $ if r == nullPtr then Nothing else Just r
-foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbol($1)"
- js_lookupSymbol :: JSString -> IO (Ptr a)
+foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbolPtr($1,$2)"
+ js_lookupSymbolPtr :: ByteArray# -> Int -> IO (Ptr a)
-lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
+lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbolInDLL _ _ = pure Nothing
resolveObjs :: IO Bool
@@ -149,27 +151,27 @@ initObjLinker :: ShouldRetainCAFs -> IO ()
initObjLinker RetainCAFs = c_initLinker_ 1
initObjLinker _ = c_initLinker_ 0
-lookupSymbol :: String -> IO (Maybe (Ptr a))
+lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbol str_in = do
let str = prefixUnderscore str_in
- withCAString str $ \c_str -> do
+ BS.useAsCString str $ \c_str -> do
addr <- c_lookupSymbol c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
-lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
+lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbolInDLL dll str_in = do
let str = prefixUnderscore str_in
- withCAString str $ \c_str -> do
+ BS.useAsCString str $ \c_str -> do
addr <- c_lookupSymbolInNativeObj dll c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
-prefixUnderscore :: String -> String
+prefixUnderscore :: BS.ShortByteString -> BS.ShortByteString
prefixUnderscore
- | cLeadingUnderscore = ('_':)
+ | cLeadingUnderscore = BS.cons (fromIntegral (ord '_'))
| otherwise = id
-- | loadDLL loads a dynamic library using the OS's native linker
@@ -298,7 +300,7 @@ isWindowsHost = False
#endif
-lookupClosure :: String -> IO (Maybe HValueRef)
+lookupClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
lookupClosure str = do
m <- lookupSymbol str
case m of
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -34,7 +34,7 @@ import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
-import qualified Data.ByteString.Short as BS
+import qualified Data.ByteString.Short.Internal as BS
import qualified Data.ByteString.Unsafe as B
import GHC.Exts
import qualified GHC.Exts.Heap as Heap
@@ -135,12 +135,12 @@ foreign import javascript "((ptr,off) => globalThis.h$loadJS(h$decodeUtf8z(ptr,o
foreign import javascript "((ptr,off) => globalThis.h$lookupClosure(h$decodeUtf8z(ptr,off)))" lookupJSClosure# :: CString -> State# RealWorld -> (# State# RealWorld, Int# #)
-lookupJSClosure' :: String -> IO Int
-lookupJSClosure' str = withCString str $ \cstr -> IO (\s ->
+lookupJSClosure' :: BS.ShortByteString -> IO Int
+lookupJSClosure' str = BS.useAsCString str $ \cstr -> IO (\s ->
case lookupJSClosure# cstr s of
(# s', r #) -> (# s', I# r #))
-lookupJSClosure :: String -> IO (Maybe HValueRef)
+lookupJSClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
lookupJSClosure str = lookupJSClosure' str >>= \case
0 -> pure Nothing
r -> pure (Just (RemoteRef (RemotePtr (fromIntegral r))))
@@ -359,7 +359,7 @@ withBreakAction opts breakMVar statusMVar mtid act
if is_exception
then pure Nothing
else do
- info_mod <- peekCString (Ptr info_mod#)
+ info_mod <- BS.packCString (Ptr info_mod#)
info_mod_uid <- BS.packCString (Ptr info_mod_uid#)
pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
@@ -434,17 +434,24 @@ mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
pokeElemOff (ptr :: Ptr CChar) len 0
return (castRemotePtr (toRemotePtr ptr))
-mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
+mkCostCentres :: RemotePtr () -> [(BS.ShortByteString, BS.ShortByteString)] -> IO [RemotePtr CostCentre]
#if defined(PROFILING)
mkCostCentres mod ccs = do
- c_module <- newCString mod
+ let c_module = fromRemotePtr $ castRemotePtr mod
mapM (mk_one c_module) ccs
where
mk_one c_module (decl_path,srcspan) = do
- c_name <- newCString decl_path
- c_srcspan <- newCString srcspan
+ c_name <- newCStringFromSBS decl_path
+ c_srcspan <- newCStringFromSBS srcspan
toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
+ newCStringFromSBS sbs = do
+ let len = BS.length sbs
+ buf <- mallocBytes $ len + 1
+ BS.copyToPtr sbs 0 buf (fromIntegral len)
+ pokeByteOff buf len (0 :: Word8)
+ pure buf
+
foreign import ccall unsafe "mkCostCentre"
c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
#else
=====================================
testsuite/tests/driver/linkwhole/Main.hs
=====================================
@@ -1,9 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import Control.Exception
import Control.Monad
+import Data.ByteString.Short (ShortByteString)
import Foreign
@@ -15,7 +17,7 @@ import GHCi.ObjLink
rotateSO
:: (FunPtr (IO (StablePtr a)) -> (IO (StablePtr a)))
- -> String
+ -> ShortByteString
-> (Maybe FilePath, FilePath)
-> IO a
rotateSO dynamicCall symName (old, newDLL) = do
=====================================
testsuite/tests/ghci/should_run/T18064.script
=====================================
@@ -1,2 +1,3 @@
+:set -XOverloadedStrings
import GHCi.ObjLink
lookupClosure "blah"
=====================================
testsuite/tests/rts/KeepCafsMain.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Main (main) where
import Foreign
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -1334,6 +1334,13 @@ class DyLD {
}
return 0;
}
+
+ lookupSymbolPtr(symPtr, symLen) {
+ const sym = new TextDecoder("utf-8", { fatal: true }).decode(
+ new Uint8Array(this.#memory.buffer, symPtr, symLen)
+ );
+ return this.lookupSymbol(sym);
+ }
}
// The main entry point of dyld that may be run on node/browser, and
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3506399809629de4e09c9aadc70100…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3506399809629de4e09c9aadc70100…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/full-eventlog-live] Support for `ghc-stack-profiler`
by Hannes Siebenhandl (＠fendor) 07 Apr '26
by Hannes Siebenhandl (＠fendor) 07 Apr '26
07 Apr '26
Hannes Siebenhandl pushed to branch wip/fendor/full-eventlog-live at Glasgow Haskell Compiler / GHC
Commits:
3d2f9b80 by fendor at 2026-04-07T10:55:21+02:00
Support for `ghc-stack-profiler`
Instrument GHC to run with `ghc-stack-profiler`
- - - - -
10 changed files:
- .gitmodules
- + ghc-stack-profiler
- ghc/Main.hs
- ghc/ghc-bin.cabal.in
- hadrian/src/Packages.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- + libraries/async
- + libraries/hashable
- + libraries/unordered-containers
Changes:
=====================================
.gitmodules
=====================================
@@ -126,3 +126,15 @@
[submodule "eventlog-socket"]
path = eventlog-socket
url = https://github.com/well-typed/eventlog-socket.git
+[submodule "ghc-stack-profiler"]
+ path = ghc-stack-profiler
+ url = https://github.com/well-typed/ghc-stack-profiler
+[submodule "libraries/async"]
+ path = libraries/async
+ url = https://github.com/fendor/async.git
+[submodule "libraries/unordered-containers"]
+ path = libraries/unordered-containers
+ url = https://github.com/fendor/unordered-containers.git
+[submodule "libraries/hashable"]
+ path = libraries/hashable
+ url = https://github.com/fendor/hashable
=====================================
ghc-stack-profiler
=====================================
@@ -0,0 +1 @@
+Subproject commit d8edeeef0b5f0babdcffc008f249a35e19cc0c8b
=====================================
ghc/Main.hs
=====================================
@@ -79,6 +79,7 @@ import GHC.Iface.Errors.Ppr
import GHC.Driver.Session.Mode
import GHC.Driver.Session.Lint
import GHC.Driver.Session.Units
+import GHC.Driver.Monad
-- Standard Haskell libraries
import System.IO
@@ -90,11 +91,24 @@ import Control.Monad.Trans.Except (throwE, runExceptT)
import Data.List ( isPrefixOf, partition, intercalate )
import Prelude
import qualified Data.List.NonEmpty as NE
+#if defined(SAMPLE_TRACER)
+import qualified GHC.Stack.Profiler as Profiler
+#endif
#if defined(EVENTLOG_SOCKET)
import GHC.Eventlog.Socket
#endif
+runWithStackProfiler :: IO () -> IO ()
+runWithStackProfiler act =
+#if defined(SAMPLE_TRACER)
+ Profiler.setupRootStackProfiler True $ \manager -> do
+ Profiler.withStackProfiler manager (Profiler.SampleIntervalMs 10) $ do
+ act
+#else
+ act
+#endif
+
-----------------------------------------------------------------------------
-- ToDo:
@@ -166,7 +180,8 @@ main = do
ShowGhciUsage -> showGhciUsage dflags
PrintWithDynFlags f -> putStrLn (f dflags)
Right postLoadMode ->
- main' postLoadMode units dflags argv3 flagWarnings
+ reifyGhc $ \session -> runWithStackProfiler $
+ reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session
main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn]
-> Ghc ()
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -32,6 +32,11 @@ Flag threaded
Default: True
Manual: True
+Flag sampleTracer
+ Description: Whether we instrument the ghc binary with sample tracer when the eventlog is enabled
+ Default: False
+ Manual: True
+
Executable ghc
Default-Language: GHC2024
@@ -50,6 +55,10 @@ Executable ghc
ghc-boot == @ProjectVersionMunged@,
ghc == @ProjectVersionMunged@
+ if flag(sampleTracer)
+ build-depends: ghc-stack-profiler
+ CPP-OPTIONS: -DSAMPLE_TRACER
+
if os(windows)
Build-Depends: Win32 >= 2.3 && < 2.15
else
=====================================
hadrian/src/Packages.hs
=====================================
@@ -14,6 +14,7 @@ module Packages (
lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
eventlogSocket, eventlogSocketControl,
ghcPackages, isGhcPackage,
+ async, hashable, unorderedContainers, ghc_stack_profiler, ghc_stack_profiler_core,
-- * Package information
crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath,
@@ -45,7 +46,9 @@ ghcPackages =
, timeout
, eventlogSocketControl, eventlogSocket
, lintersCommon
- , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ]
+ , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
+ , async, hashable, unorderedContainers, ghc_stack_profiler_core, ghc_stack_profiler
+ ]
-- TODO: Optimise by switching to sets of packages.
isGhcPackage :: Package -> Bool
@@ -139,6 +142,11 @@ win32 = lib "Win32"
xhtml = lib "xhtml"
eventlogSocket = lib "eventlog-socket" `setPath` "eventlog-socket/eventlog-socket"
eventlogSocketControl = lib "eventlog-socket-control" `setPath` "eventlog-socket/eventlog-socket-control"
+async = lib "async"
+hashable = lib "hashable"
+unorderedContainers = lib "unordered-containers"
+ghc_stack_profiler = lib "ghc-stack-profiler" `setPath` "ghc-stack-profiler/ghc-stack-profiler"
+ghc_stack_profiler_core = lib "ghc-stack-profiler-core" `setPath` "ghc-stack-profiler/ghc-stack-profiler-core"
lintersCommon = lib "linters-common" `setPath` "linters/linters-common"
lintNotes = linter "lint-notes"
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -184,6 +184,11 @@ stage1Packages = do
, unlit
, xhtml
, if winTarget then win32 else unix
+ , ghc_stack_profiler
+ , ghc_stack_profiler_core
+ , async
+ , hashable
+ , unorderedContainers
]
, when (not cross)
[ hpcBin
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -132,6 +132,7 @@ packageArgs = do
, builder (Cabal Flags) ? mconcat
[ (expr (ghcWithInterpreter stage)) `cabalFlag` "internal-interpreter"
, notStage0 `cabalFlag` "eventlog-socket"
+ , notStage0 `cabalFlag` "sampleTracer"
, ifM stage0
-- We build a threaded stage 1 if the bootstrapping compiler
-- supports it.
=====================================
libraries/async
=====================================
@@ -0,0 +1 @@
+Subproject commit d5fdfb9117a983a3f07b213a8a4f8b1256a80f8c
=====================================
libraries/hashable
=====================================
@@ -0,0 +1 @@
+Subproject commit 535d33ef02bcabd06758f0ec6920ff9c02ef158f
=====================================
libraries/unordered-containers
=====================================
@@ -0,0 +1 @@
+Subproject commit 207901b4ded4799e41e0d4d45c3b198424ea4d17
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d2f9b80ed945fc38befbb9db355605…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d2f9b80ed945fc38befbb9db355605…
You're receiving this email because of your account on gitlab.haskell.org.
1
0