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