16 Apr '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
e8a196c6 by sheaf at 2026-04-16T13:31:19-04:00
Deal with 'noSpec' in 'coreExprToPmLit'
This commit makes two separate changes relating to
'GHC.HsToCore.Pmc.Solver.Types.coreExprAsPmLit':
1. Commit 7124e4ad mistakenly marked deferred errors as non-canonical,
which led to the introduction of 'nospec' wrappers in the
generated Core. This reverts that accident by declaring deferred
errors as being canonical, avoiding spurious 'nospec' wrapping.
2. Look through magic identity-like Ids such as 'nospec', 'inline' and
'lazy' in 'coreExprAsPmLit', just like Core Prep does.
There might genuinely be incoherent evidence, but that shouldn't
obstruct the pattern match checker. See test T27124a.
Fixes #25926 #27124
-------------------------
Metric Decrease:
T3294
-------------------------
- - - - -
11 changed files:
- + changelog.d/T27124.md
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/Tc/Errors.hs
- + testsuite/tests/overloadedstrings/should_fail/T25926.hs
- + testsuite/tests/overloadedstrings/should_fail/T25926.stderr
- + testsuite/tests/overloadedstrings/should_fail/T27124.hs
- + testsuite/tests/overloadedstrings/should_fail/T27124.stderr
- + testsuite/tests/overloadedstrings/should_fail/all.T
- + testsuite/tests/overloadedstrings/should_run/T27124a.hs
- testsuite/tests/overloadedstrings/should_run/all.T
Changes:
=====================================
changelog.d/T27124.md
=====================================
@@ -0,0 +1,10 @@
+section: compiler
+issues: #25926 #27124
+mrs: !15895
+synopsis:
+ Fix "failed to detect OverLit" panic in the pattern-match checker.
+description:
+ Fixed an issue in which overloaded literals (e.g. numeric literals, overloaded
+ strings with -XOverloadedStrings, overloaded lists, etc) could cause a GHC
+ crash when using -fdefer-type-errors, with an error message of the form
+ "failed to detect OverLit".
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -1055,6 +1055,9 @@ cpeApp top_env expr
|| f `hasKey` nospecIdKey -- Replace (nospec a) with a
-- See Note [nospecId magic] in GHC.Types.Id.Make
+ -- NB: keep this in sync with GHC.HsToCore.Pmc.Solver.Types.coreExprAsPmLit,
+ -- as that also needs to see through these magic Ids.
+
-- Consider the code:
--
-- lazy (f x) y
=====================================
compiler/GHC/HsToCore/Pmc/Solver/Types.hs
=====================================
@@ -694,6 +694,15 @@ coreExprAsPmLit :: CoreExpr -> Maybe PmLit
coreExprAsPmLit (Tick _t e) = coreExprAsPmLit e
coreExprAsPmLit (Lit l) = literalToPmLit (literalType l) l
coreExprAsPmLit e = case collectArgs e of
+
+ -- Look through nospec, noinline and lazy, which are only eliminated by Core Prep.
+ -- See Note [coreExprAsPmLit and nospec]
+ (Var x, Type _ : inner : rest_args)
+ | x `hasKey` nospecIdKey
+ || x `hasKey` noinlineIdKey
+ || x `hasKey` lazyIdKey
+ -> coreExprAsPmLit (mkApps inner rest_args)
+
(Var x, [Lit l])
| Just dc <- isDataConWorkId_maybe x
, dc `elem` [intDataCon, wordDataCon, charDataCon, floatDataCon, doubleDataCon]
@@ -834,6 +843,34 @@ with large exponents case. This will return a `PmLitOverRat` literal.
Which is then passed to overloadPmLit which simply returns it as-is since
it's already overloaded.
+Note [coreExprAsPmLit and nospec]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For coverage checking, we need to analyse overloaded literal patterns to figure
+out which literals they correspond to; this is what 'coreExprAsPmLit' does.
+For example, the literal pattern "fromString" (with -XOverloadedStrings)
+will turn into an equality check against the **expression**
+
+ fromString @T $dFromString "hello"#
+
+and 'coreExprAsPmLit' recovers the string by taking apart this application.
+
+However, when $dFromString is non-canonical (e.g. when an INCOHERENT
+instance was discarded during resolution of the typeclass constraint, or when
+the dictionary comes from 'withDict'), the desugarer wraps 'fromString' in
+'nospec' (as per Note [nospecId magic] in GHC.Types.Id.Make and
+Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr):
+
+ nospec @(IsString a => String -> Maybe a) fromString @T $dFromString "hello"#
+
+(For a full example, see test case T27124a.)
+
+The 'nospec' mechanism only exists for the specialiser; it should be transparent
+to everything else. 'coreExprAsPmLit' must thus look through the 'nospec'
+application in order obtain the string "hello". If it doesn't, we can't do
+pattern match checking (in fact GHC.HsToCore.Pmc.Desugar.desugarPat is liable
+to crash!).
+
+The same reasoning applies to `noinline` and `lazy`.
-}
instance Outputable PmLitValue where
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -1360,11 +1360,11 @@ addDeferredBinding ctxt supp hints msg (EI { ei_evdest = Just dest
; case dest of
EvVarDest evar
- -> addTcEvBind ev_binds_var $ mkWantedEvBind evar EvNonCanonical err_tm
+ -> addTcEvBind ev_binds_var $ mkWantedEvBind evar EvCanonical err_tm
HoleDest hole
-> do { -- See Note [Deferred errors for coercion holes]
let co_var = coHoleCoVar hole
- ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvNonCanonical err_tm
+ ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvCanonical err_tm
; fillCoercionHole hole (CPH { cph_co = mkCoVarCo co_var
, cph_holes = emptyCoHoleSet }) } }
addDeferredBinding _ _ _ _ _ = return () -- Do not set any evidence for Given
=====================================
testsuite/tests/overloadedstrings/should_fail/T25926.hs
=====================================
@@ -0,0 +1,4 @@
+module T25926 where
+
+f () 0 = ()
+f 'a' _ = ()
=====================================
testsuite/tests/overloadedstrings/should_fail/T25926.stderr
=====================================
@@ -0,0 +1,5 @@
+T25926.hs:4:3: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match expected type ‘()’ with actual type ‘Char’
+ • In the pattern: 'a'
+ In an equation for ‘f’: f 'a' _ = ()
+
=====================================
testsuite/tests/overloadedstrings/should_fail/T27124.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module T27124 where
+
+foo :: [String] -> Bool
+foo "HI" = True
+foo _ = False
+
+main = pure ()
=====================================
testsuite/tests/overloadedstrings/should_fail/T27124.stderr
=====================================
@@ -0,0 +1,6 @@
+T27124.hs:6:5: warning: [GHC-18872] [-Wdeferred-type-errors (in -Wdefault)]
+ • Couldn't match type ‘[Char]’ with ‘Char’
+ arising from the literal ‘"HI"’
+ • In the pattern: "HI"
+ In an equation for ‘foo’: foo "HI" = True
+
=====================================
testsuite/tests/overloadedstrings/should_fail/all.T
=====================================
@@ -0,0 +1,2 @@
+test('T25926', normal, compile, ['-fdefer-type-errors'])
+test('T27124', normal, compile, ['-fdefer-type-errors'])
=====================================
testsuite/tests/overloadedstrings/should_run/T27124a.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module T27124a where
+
+import Data.String (IsString(..))
+
+newtype Wrap a = Wrap a deriving (Eq, Show)
+
+instance IsString a => IsString (Wrap a) where
+ fromString = Wrap . fromString
+
+instance {-# INCOHERENT #-} IsString (Wrap Bool) where
+ fromString _ = Wrap False
+
+f :: (Eq a, IsString a) => Wrap a -> Bool
+f "hello" = True
+f _ = False
+
+main :: IO ()
+main = do
+ print (f (Wrap ("hello" :: String)))
+ print (f (Wrap ("world" :: String)))
=====================================
testsuite/tests/overloadedstrings/should_run/all.T
=====================================
@@ -1 +1,2 @@
test('overloadedstringsrun01', normal, compile_and_run, [''])
+test('T27124a', normal, compile, ['-fno-specialise-incoherents'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8a196c65cee32f06c3d99b74af3345…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8a196c65cee32f06c3d99b74af3345…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
d178ee89 by Sylvain Henry at 2026-04-16T13:30:25-04:00
Add changelog for #15973
- - - - -
1 changed file:
- + changelog.d/T15973
Changes:
=====================================
changelog.d/T15973
=====================================
@@ -0,0 +1,6 @@
+section: ghc-lib
+synopsis: GHC now represents target's Int constants internally with a TargetInt
+ (~Int64) in order to avoid overflows when cross-compiling from a 32-bit
+ architecture to a 64-bit one.
+issues: #15973
+mrs: !15883
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d178ee89405aad63e0482e0e803bfe3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d178ee89405aad63e0482e0e803bfe3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
16 Apr '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
a0d6f1f4 by Simon Jakobi at 2026-04-16T13:29:28-04:00
Add regression test for #9074
Closes #9074.
- - - - -
6 changed files:
- + testsuite/tests/ghci/T9074/Makefile
- + testsuite/tests/ghci/T9074/T9074.hs
- + testsuite/tests/ghci/T9074/T9074.stdout
- + testsuite/tests/ghci/T9074/T9074a.c
- + testsuite/tests/ghci/T9074/T9074b.c
- + testsuite/tests/ghci/T9074/all.T
Changes:
=====================================
testsuite/tests/ghci/T9074/Makefile
=====================================
@@ -0,0 +1,12 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: T9074
+T9074 :
+ "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -c -fPIC T9074b.c
+ "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -c -fPIC T9074a.c
+ # Historically, loading T9074b.o before T9074a.o could fail with
+ # "Loading temp shared object failed ... undefined symbol: shared_value".
+ echo "main" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) \
+ -v0 T9074b.o T9074a.o T9074.hs
=====================================
testsuite/tests/ghci/T9074/T9074.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+foreign import ccall unsafe "read_from_b" readFromB :: IO Int
+
+main :: IO ()
+main = readFromB >>= print
=====================================
testsuite/tests/ghci/T9074/T9074.stdout
=====================================
@@ -0,0 +1 @@
+65
=====================================
testsuite/tests/ghci/T9074/T9074a.c
=====================================
@@ -0,0 +1 @@
+int shared_value = 65;
=====================================
testsuite/tests/ghci/T9074/T9074b.c
=====================================
@@ -0,0 +1,5 @@
+extern int shared_value;
+
+int read_from_b(void) {
+ return shared_value;
+}
=====================================
testsuite/tests/ghci/T9074/all.T
=====================================
@@ -0,0 +1,4 @@
+test('T9074',
+ [req_c,
+ req_interp],
+ makefile_test, [])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a0d6f1f40fb39b7960754c0ecc568a5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a0d6f1f40fb39b7960754c0ecc568a5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
2dadf3b0 by sheaf at 2026-04-16T13:28:39-04: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.
The most important change is that we revert the logic (added in 85b0aae2)
that allowed ticks to be placed around coercions, which caused serious
issues (e.g. #27121). It was just a mistake, as it doesn't make sense
to put a tick around a coercion.
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)
- combine profiling ticks into one when possible
Fixes #26878, #26941 and #27121
Co-authored-by: simonpj <simon.peytonjones(a)gmail.com>
- - - - -
12 changed files:
- + changelog.d/T27121.md
- compiler/GHC/Core/Opt/FloatOut.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Stg/Debug.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:
=====================================
changelog.d/T27121.md
=====================================
@@ -0,0 +1,8 @@
+section: compiler
+issues: #26878 #26941 #27121
+mrs: !15494
+synopsis:
+ Avoid putting ticks around coercions
+description:
+ Fix a regression in which GHC could place ticks around coercions, which
+ could cause knock-on GHC panics (as reported in #27121).
=====================================
compiler/GHC/Core/Opt/FloatOut.hs
=====================================
@@ -383,10 +383,40 @@ 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.
+
+Failing to do so can result in stacks of millions of duplicated source notes!
+This happened e.g. when compiling the LintCodes.Static testsuite file.
+-}
floatExpr (Cast expr co)
= case (floatExpr expr) of { (fs, floating_defns, expr') ->
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -109,6 +109,7 @@ import GHC.Data.Maybe
import GHC.Data.List.SetOps( minusList )
import GHC.Data.OrdList
+import GHC.Data.Bag (emptyBag, snocBag, bagToList)
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -118,6 +119,7 @@ import Control.Monad ( guard )
import Data.ByteString ( ByteString )
import Data.Function ( on )
import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
+import qualified Data.List.NonEmpty as NE
import Data.Ord ( comparing )
import qualified Data.Set as Set
@@ -303,105 +305,303 @@ 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.
- 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)
+ -- mkTick' handles floating of tick `t` *into* the expression.
+ mkTick' :: CoreExpr -> CoreExpr
+ mkTick' expr
+ -- Deal with ticking a expression headed by one or more ticks.
+ | Just (ts, e) <- tickedExpr_maybe expr
+ = tickTickedExpr t ts e
+ mkTick' expr = case expr of
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
+
+-- | Apply a tick to an expression headed by ticks.
+tickTickedExpr
+ :: CoreTickish -- ^ tick to add
+ -> NE.NonEmpty CoreTickish -- ^ existing stack of ticks
+ -> CoreExpr -- ^ inner core expression
+ -> CoreExpr
+tickTickedExpr t1 t2s e
+
+ -- Case 1: common up 't1' with a tick in the stack.
+ --
+ -- It's important to look at the whole stack to expose more opportunities for
+ -- combination.
+ -- See Note [Avoiding duplicate ticks] in GHC.Core.Opt.FloatOut
+ -- and Note [Ordering of source notes] in GHC.Types.Tickish.
+ | Just t2s' <- combine_into_stack t2s
+ = apply_ticks t2s' e
+
+ -- Case 2: 't1' can be commuted past all the ticks in the stack, e.g. because
+ -- it has tighter placement properties than all the ticks in the stack.
+ -- Push it inwards to expose cancellation opportunities.
+ | all (tickishCommutable t1) t2s
+ = apply_ticks t2s $ mkTick t1 e
+
+ -- Fallback: keep the new tick on the outside.
+ | otherwise
+ = apply_ticks (t1 NE.:| NE.toList t2s) e
+
+ where
+ apply_ticks :: NE.NonEmpty CoreTickish -> CoreExpr -> CoreExpr
+ apply_ticks ts e' = foldr Tick e' ts
+
+ -- Try to combine 't1' into a stack of ticks.
+ combine_into_stack :: NE.NonEmpty CoreTickish -> Maybe (NE.NonEmpty CoreTickish)
+ combine_into_stack (t2 NE.:| rest)
+ | Just t2' <- combineTickish_maybe t1 t2
+ = Just (t2' NE.:| rest)
+ | r_hd : r_tl <- rest
+ , Just rest' <- combine_into_stack (r_hd NE.:| r_tl)
+ = Just (t2 NE.:| NE.toList rest')
+ | otherwise
+ = Nothing
+
+{- 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.
+
+ (PSCC3) Push the SCC inside saturated contructor applications.
- -- Catch-all: Annotate where we stand
- _any -> Tick t $ rest expr
+ 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
+-- | Is this expression headed by a stack of ticks?
+tickedExpr_maybe :: CoreExpr -> Maybe (NE.NonEmpty CoreTickish, CoreExpr)
+tickedExpr_maybe = go emptyBag
+ where
+ go ts (Tick t e) = go (ts `snocBag` t) e
+ go ts e = case bagToList ts of
+ [] -> Nothing
+ t2:rest -> Just (t2 NE.:| rest, e)
+
isSaturatedConApp :: CoreExpr -> Bool
isSaturatedConApp e = go e []
where go (App f a) as = go f (a:as)
@@ -2545,8 +2745,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/Stg/Debug.hs
=====================================
@@ -212,10 +212,8 @@ shouldMakeDistinctTable StgDebugOpts{stgDebug_distinctConstructorTables} dc =
where
dcStr = occNameString . occName $ dataConName dc
-{-
-Note [Mapping Info Tables to Source Positions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
+{- Note [Mapping Info Tables to Source Positions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This note describes what the `-finfo-table-map` flag achieves.
When debugging memory issues it is very useful to be able to map a specific closure
=====================================
compiler/GHC/Types/Tickish.hs
=====================================
@@ -17,6 +17,8 @@ module GHC.Types.Tickish (
TickishPlacement(..),
tickishPlace,
tickishContains,
+ combineTickish_maybe,
+ tickishCommutable,
-- * Breakpoint tick identifiers
BreakpointId(..), BreakTickIndex
@@ -140,20 +142,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 +159,70 @@ 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)
+
+This functionality is enabled by using the -g flag (DWARF debug information).
+Source notes ticks are also enabled by the -finfo-table-map and
+-fprof-late-overloaded-calls flags; see GHC.Driver.Session.needSourceNotes.
+
+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.
+
+Note [Ordering of source notes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The ordering of source notes is important:
+
+ - inner ticks represent the original, most immediate source location of the
+ syntax tree node they wrap (the definition site),
+ - outer ticks represent the lexical or execution context into which that
+ expression was placed or inlined (the use site).
+
+We thus try to avoid commuting source note ticks past eachother in order to
+preserve this ordering. However, we must still cancel out duplicate source
+notes, e.g.:
+
+ mkTick src<loc2> (mkTick src<loc1>) (src<loc3> src<loc2> src<loc1> e)
+
+ ==>
+
+ src<loc3> src<loc2> src<loc1> e
+
+To do this, 'combineTickishs_maybe' peeks at the rest of the stack to expose
+cancellation opportunities, but 'mkTick' otherwise takes care not to
+commute source notes.
+-}
+
--------------------------------------------------------------------------------
-- Tick breakpoint index
--------------------------------------------------------------------------------
@@ -261,8 +314,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 +347,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 +432,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 +553,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 +573,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 +584,63 @@ 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
+
+-- | Can these two ticks be commuted (moved past eachother)?
+tickishCommutable :: GenTickish pass -> GenTickish pass -> Bool
+tickishCommutable
+ -- Profiling ticks for different cost centres should never be re-ordered
+ -- relative to each other.
+ (ProfNote { profNoteCC = cc1 }) (ProfNote { profNoteCC = cc2 })
+ = cc1 == cc2
+
+tickishCommutable t1 t2
+ -- 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]
+ | tickishPlace t1 /= tickishPlace t2
+ = True
+
+ -- Don't commute other ticks. In particular, don't commute two SourceNote
+ -- ticks, as per Note [Ordering of source notes] in GHC.Types.Tickish.
+ | otherwise
+ = False
+
-- | 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/2dadf3b0d057c087af812e5dd33fe41…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2dadf3b0d057c087af812e5dd33fe41…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/27162/ghc-codegen-panic] WIP Fix windows dynamic linking panic: genForeignCall.assign_code many
by David Eichmann (＠DavidEichmann) 16 Apr '26
by David Eichmann (＠DavidEichmann) 16 Apr '26
16 Apr '26
David Eichmann pushed to branch wip/27162/ghc-codegen-panic at Glasgow Haskell Compiler / GHC
Commits:
b8bb398e by David Eichmann at 2026-04-16T17:03:11+01:00
WIP Fix windows dynamic linking panic: genForeignCall.assign_code many
- - - - -
8 changed files:
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/AArch64.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/X86.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Utils/Panic/Plain.hs
Changes:
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -132,7 +132,7 @@ import System.IO
import System.Directory ( getCurrentDirectory )
--------------------
-nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle
+nativeCodeGen :: forall a . HasCallStack => Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle
-> CgStream RawCmmGroup a
-> UniqDSMT IO a
nativeCodeGen logger ts config modLoc h cmms
=====================================
compiler/GHC/CmmToAsm/AArch64.hs
=====================================
@@ -18,8 +18,9 @@ import qualified GHC.CmmToAsm.AArch64.Ppr as AArch64
import qualified GHC.CmmToAsm.AArch64.CodeGen as AArch64
import qualified GHC.CmmToAsm.AArch64.Regs as AArch64
import qualified GHC.CmmToAsm.AArch64.RegInfo as AArch64
+import GHC.Stack (HasCallStack)
-ncgAArch64 :: NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest
+ncgAArch64 :: HasCallStack => NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest
ncgAArch64 config
= NcgImpl {
ncgConfig = config
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -95,7 +95,7 @@ import GHC.Utils.Monad (mapAccumLM)
-- data GenBasicBlock i = BasicBlock BlockId [i]
cmmTopCodeGen
- :: RawCmmDecl
+ :: HasCallStack => RawCmmDecl
-> NatM [NatCmmDecl RawCmmStatics Instr]
-- Thus we'll have to deal with either CmmProc ...
@@ -123,7 +123,7 @@ cmmTopCodeGen _cmm@(CmmData sec dat) = do
return [CmmData sec dat] -- no translation, we just use CmmStatic
basicBlockCodeGen
- :: Block CmmNode C C
+ :: HasCallStack => Block CmmNode C C
-> NatM ( [NatBasicBlock Instr]
, [NatCmmDecl RawCmmStatics Instr])
=====================================
compiler/GHC/CmmToAsm/X86.hs
=====================================
@@ -19,12 +19,13 @@ import qualified GHC.CmmToAsm.X86.Instr as X86
import qualified GHC.CmmToAsm.X86.Ppr as X86
import qualified GHC.CmmToAsm.X86.CodeGen as X86
import qualified GHC.CmmToAsm.X86.Regs as X86
+import GHC.Stack (HasCallStack)
ncgX86 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest
ncgX86 = ncgX86_64
-ncgX86_64 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest
+ncgX86_64 :: HasCallStack => NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest
ncgX86_64 config = NcgImpl
{ ncgConfig = config
, cmmTopCodeGen = X86.cmmTopCodeGen
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -142,7 +142,7 @@ avx512dqEnabled :: NatM Bool
avx512dqEnabled = ncgAvx512dqEnabled <$> getConfig
cmmTopCodeGen
- :: RawCmmDecl
+ :: HasCallStack => RawCmmDecl
-> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]
cmmTopCodeGen (CmmProc info lab live graph) = do
@@ -212,7 +212,7 @@ verifyBasicBlock platform instrs
(pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))
basicBlockCodeGen
- :: CmmBlock
+ :: HasCallStack => CmmBlock
-> NatM ( [NatBasicBlock Instr]
, [NatCmmDecl (Alignment, RawCmmStatics) Instr])
@@ -325,7 +325,7 @@ which *are* known to change the basic block.
-- See Note [Keeping track of the current block] for why
-- we pass the BlockId.
-stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.
+stmtsToInstrs :: HasCallStack => BlockId -- ^ Basic block these statement will start to be placed in.
-> [CmmNode O O] -- ^ Cmm Statement
-> NatM (InstrBlock, BlockId) -- ^ Resulting instruction
stmtsToInstrs bid stmts =
@@ -341,7 +341,8 @@ stmtsToInstrs bid stmts =
-- | `bid` refers to the current block and is used to update the CFG
-- if new blocks are inserted in the control flow.
-- See Note [Keeping track of the current block] for more details.
-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.
+stmtToInstrs :: HasCallStack
+ => BlockId -- ^ Basic block this statement will start to be placed in.
-> CmmNode e x
-> NatM (InstrBlock, Maybe BlockId)
-- ^ Instructions, and bid of new block if successive
@@ -546,7 +547,7 @@ assignReg_I64Code (CmmLocal dst) valueTree = do
assignReg_I64Code _ _
= panic "assignReg_I64Code(i386): invalid lvalue"
-iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
+iselExpr64 :: HasCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
iselExpr64 (CmmLit (CmmInt i _)) = do
Reg64 rhi rlo <- getNewReg64
let
@@ -855,12 +856,12 @@ iselExpr64ParallelBin op e1 e2 = do
--------------------------------------------------------------------------------
-getRegister :: HasDebugCallStack => CmmExpr -> NatM Register
+getRegister :: HasCallStack => CmmExpr -> NatM Register
getRegister e = do platform <- getPlatform
is32Bit <- is32BitPlatform
getRegister' platform is32Bit e
-getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register
+getRegister' :: HasCallStack => Platform -> Bool -> CmmExpr -> NatM Register
getRegister' platform is32Bit (CmmReg reg)
= case reg of
@@ -3412,12 +3413,12 @@ intLoadCode instr mem = do
-- Compute an expression into *any* register, adding the appropriate
-- move instruction if necessary.
-getAnyReg :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock)
+getAnyReg :: HasCallStack => CmmExpr -> NatM (Reg -> InstrBlock)
getAnyReg expr = do
r <- getRegister expr
anyReg r
-anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock)
+anyReg :: HasCallStack => Register -> NatM (Reg -> InstrBlock)
anyReg (Any _ code) = return code
anyReg (Fixed rep reg fcode) = do
config <- getConfig
@@ -3426,7 +3427,7 @@ anyReg (Fixed rep reg fcode) = do
-- A bit like getSomeReg, but we want a reg that can be byte-addressed.
-- Fixed registers might not be byte-addressable, so we make sure we've
-- got a temporary, inserting an extra reg copy if necessary.
-getByteReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)
+getByteReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock)
getByteReg expr = do
config <- getConfig
is32Bit <- is32BitPlatform
@@ -3448,7 +3449,7 @@ getByteReg expr = do
-- Another variant: this time we want the result in a register that cannot
-- be modified by code to evaluate an arbitrary expression.
-getNonClobberedReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)
+getNonClobberedReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock)
getNonClobberedReg expr = do
r <- getRegister expr
config <- getConfig
@@ -4324,7 +4325,8 @@ genCondBranch' _ bid id false bool = do
-- to take/return a block id.
genForeignCall
- :: ForeignTarget -- ^ function to call
+ :: HasCallStack
+ => ForeignTarget -- ^ function to call
-> [CmmFormal] -- ^ where to put the result
-> [CmmActual] -- ^ arguments (of mixed type)
-> BlockId -- ^ The block we are in
@@ -4559,7 +4561,7 @@ loadIntoRegMightClobberOtherReg _ = True
-- | Generate C call to the given function in ghc-prim
genPrimCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4574,7 +4576,7 @@ genPrimCCall bid lbl_txt dsts args = do
-- | Generate C call to the given function in libc
genLibCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4592,7 +4594,7 @@ genLibCCall bid lbl_txt dsts args = do
-- | Generate C call to the given function in the RTS
genRTSCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4608,7 +4610,7 @@ genRTSCCall bid lbl_txt dsts args = do
-- | Generate a real C call to the given address with the given convention
genCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> CmmExpr
-> ForeignConvention
-> [CmmFormal]
@@ -4786,7 +4788,7 @@ genCCall32 addr _conv dest_regs args = do
call `appOL`
assign_code dest_regs)
-genCCall64 :: CmmExpr -- ^ address of function to call
+genCCall64 :: HasCallStack => CmmExpr -- ^ address of function to call
-> ForeignConvention -- ^ calling convention
-> [CmmFormal] -- ^ where to put the result
-> [CmmActual] -- ^ arguments (of mixed type)
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -63,6 +63,7 @@ import GHC.Types.Unique.Supply ( UniqueTag(..) )
import System.IO
import Data.Set (Set)
import qualified Data.Set as Set
+import GHC.Stack (HasCallStack)
{-
************************************************************************
@@ -74,7 +75,7 @@ import qualified Data.Set as Set
codeOutput
:: forall a.
- Logger
+ HasCallStack => Logger
-> TmpFs
-> LlvmConfigCache
-> DynFlags
@@ -192,7 +193,7 @@ outputC logger dflags filenm dus cmm_stream unit_deps =
************************************************************************
-}
-outputAsm :: Logger
+outputAsm :: HasCallStack => Logger
-> DynFlags
-> Module
-> ModLocation
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1941,7 +1941,7 @@ hscSimpleIface' mb_core_program tc_result summary = do
--------------------------------------------------------------
-- | Compile to hard-code.
-hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
+hscGenHardCode :: HasCallStack => HscEnv -> CgGuts -> ModLocation -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )
-- ^ @Just f@ <=> _stub.c is f
hscGenHardCode hsc_env cgguts mod_loc output_filename = do
@@ -2246,7 +2246,7 @@ generateFreshByteCodeLinkable hsc_env mod_name cgguts mod_location = do
return $ mkModuleByteCodeLinkable bco_time bco_object
------------------------------
-hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
+hscCompileCmmFile :: HasCallStack => HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
=====================================
compiler/GHC/Utils/Panic/Plain.hs
=====================================
@@ -92,12 +92,12 @@ showPlainGhcException =
. s . showString "\n\n"
. showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
-throwPlainGhcException :: PlainGhcException -> a
+throwPlainGhcException :: HasCallStack => PlainGhcException -> a
throwPlainGhcException = Exception.throw
-- | Panics and asserts.
panic, sorry, pgmError :: HasCallStack => String -> a
-panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic x)
+panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic (unlines [x, show callStack]))
sorry x = throwPlainGhcException (PlainSorry x)
pgmError x = throwPlainGhcException (PlainProgramError x)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8bb398e3c1b43f030501971db8ffb3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8bb398e3c1b43f030501971db8ffb3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/27162/ghc-codegen-panic] WIP Fix windows dynamic linking panic: genForeignCall.assign_code many
by David Eichmann (＠DavidEichmann) 16 Apr '26
by David Eichmann (＠DavidEichmann) 16 Apr '26
16 Apr '26
David Eichmann pushed to branch wip/27162/ghc-codegen-panic at Glasgow Haskell Compiler / GHC
Commits:
27297996 by David Eichmann at 2026-04-16T17:02:06+01:00
WIP Fix windows dynamic linking panic: genForeignCall.assign_code many
- - - - -
8 changed files:
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/AArch64.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/X86.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Utils/Panic/Plain.hs
Changes:
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -132,7 +132,7 @@ import System.IO
import System.Directory ( getCurrentDirectory )
--------------------
-nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle
+nativeCodeGen :: forall a . HasCallStack => Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle
-> CgStream RawCmmGroup a
-> UniqDSMT IO a
nativeCodeGen logger ts config modLoc h cmms
=====================================
compiler/GHC/CmmToAsm/AArch64.hs
=====================================
@@ -18,8 +18,9 @@ import qualified GHC.CmmToAsm.AArch64.Ppr as AArch64
import qualified GHC.CmmToAsm.AArch64.CodeGen as AArch64
import qualified GHC.CmmToAsm.AArch64.Regs as AArch64
import qualified GHC.CmmToAsm.AArch64.RegInfo as AArch64
+import GHC.Stack (HasCallStack)
-ncgAArch64 :: NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest
+ncgAArch64 :: HasCallStack => NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest
ncgAArch64 config
= NcgImpl {
ncgConfig = config
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -95,7 +95,7 @@ import GHC.Utils.Monad (mapAccumLM)
-- data GenBasicBlock i = BasicBlock BlockId [i]
cmmTopCodeGen
- :: RawCmmDecl
+ :: HasCallStack => RawCmmDecl
-> NatM [NatCmmDecl RawCmmStatics Instr]
-- Thus we'll have to deal with either CmmProc ...
@@ -123,7 +123,7 @@ cmmTopCodeGen _cmm@(CmmData sec dat) = do
return [CmmData sec dat] -- no translation, we just use CmmStatic
basicBlockCodeGen
- :: Block CmmNode C C
+ :: HasCallStack => Block CmmNode C C
-> NatM ( [NatBasicBlock Instr]
, [NatCmmDecl RawCmmStatics Instr])
=====================================
compiler/GHC/CmmToAsm/X86.hs
=====================================
@@ -24,7 +24,7 @@ ncgX86 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest
ncgX86 = ncgX86_64
-ncgX86_64 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest
+ncgX86_64 :: HasCallStack => NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest
ncgX86_64 config = NcgImpl
{ ncgConfig = config
, cmmTopCodeGen = X86.cmmTopCodeGen
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -142,7 +142,7 @@ avx512dqEnabled :: NatM Bool
avx512dqEnabled = ncgAvx512dqEnabled <$> getConfig
cmmTopCodeGen
- :: RawCmmDecl
+ :: HasCallStack => RawCmmDecl
-> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]
cmmTopCodeGen (CmmProc info lab live graph) = do
@@ -212,7 +212,7 @@ verifyBasicBlock platform instrs
(pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))
basicBlockCodeGen
- :: CmmBlock
+ :: HasCallStack => CmmBlock
-> NatM ( [NatBasicBlock Instr]
, [NatCmmDecl (Alignment, RawCmmStatics) Instr])
@@ -325,7 +325,7 @@ which *are* known to change the basic block.
-- See Note [Keeping track of the current block] for why
-- we pass the BlockId.
-stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.
+stmtsToInstrs :: HasCallStack => BlockId -- ^ Basic block these statement will start to be placed in.
-> [CmmNode O O] -- ^ Cmm Statement
-> NatM (InstrBlock, BlockId) -- ^ Resulting instruction
stmtsToInstrs bid stmts =
@@ -341,7 +341,8 @@ stmtsToInstrs bid stmts =
-- | `bid` refers to the current block and is used to update the CFG
-- if new blocks are inserted in the control flow.
-- See Note [Keeping track of the current block] for more details.
-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.
+stmtToInstrs :: HasCallStack
+ => BlockId -- ^ Basic block this statement will start to be placed in.
-> CmmNode e x
-> NatM (InstrBlock, Maybe BlockId)
-- ^ Instructions, and bid of new block if successive
@@ -546,7 +547,7 @@ assignReg_I64Code (CmmLocal dst) valueTree = do
assignReg_I64Code _ _
= panic "assignReg_I64Code(i386): invalid lvalue"
-iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
+iselExpr64 :: HasCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
iselExpr64 (CmmLit (CmmInt i _)) = do
Reg64 rhi rlo <- getNewReg64
let
@@ -855,12 +856,12 @@ iselExpr64ParallelBin op e1 e2 = do
--------------------------------------------------------------------------------
-getRegister :: HasDebugCallStack => CmmExpr -> NatM Register
+getRegister :: HasCallStack => CmmExpr -> NatM Register
getRegister e = do platform <- getPlatform
is32Bit <- is32BitPlatform
getRegister' platform is32Bit e
-getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register
+getRegister' :: HasCallStack => Platform -> Bool -> CmmExpr -> NatM Register
getRegister' platform is32Bit (CmmReg reg)
= case reg of
@@ -3412,12 +3413,12 @@ intLoadCode instr mem = do
-- Compute an expression into *any* register, adding the appropriate
-- move instruction if necessary.
-getAnyReg :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock)
+getAnyReg :: HasCallStack => CmmExpr -> NatM (Reg -> InstrBlock)
getAnyReg expr = do
r <- getRegister expr
anyReg r
-anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock)
+anyReg :: HasCallStack => Register -> NatM (Reg -> InstrBlock)
anyReg (Any _ code) = return code
anyReg (Fixed rep reg fcode) = do
config <- getConfig
@@ -3426,7 +3427,7 @@ anyReg (Fixed rep reg fcode) = do
-- A bit like getSomeReg, but we want a reg that can be byte-addressed.
-- Fixed registers might not be byte-addressable, so we make sure we've
-- got a temporary, inserting an extra reg copy if necessary.
-getByteReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)
+getByteReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock)
getByteReg expr = do
config <- getConfig
is32Bit <- is32BitPlatform
@@ -3448,7 +3449,7 @@ getByteReg expr = do
-- Another variant: this time we want the result in a register that cannot
-- be modified by code to evaluate an arbitrary expression.
-getNonClobberedReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)
+getNonClobberedReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock)
getNonClobberedReg expr = do
r <- getRegister expr
config <- getConfig
@@ -4324,7 +4325,8 @@ genCondBranch' _ bid id false bool = do
-- to take/return a block id.
genForeignCall
- :: ForeignTarget -- ^ function to call
+ :: HasCallStack
+ => ForeignTarget -- ^ function to call
-> [CmmFormal] -- ^ where to put the result
-> [CmmActual] -- ^ arguments (of mixed type)
-> BlockId -- ^ The block we are in
@@ -4559,7 +4561,7 @@ loadIntoRegMightClobberOtherReg _ = True
-- | Generate C call to the given function in ghc-prim
genPrimCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4574,7 +4576,7 @@ genPrimCCall bid lbl_txt dsts args = do
-- | Generate C call to the given function in libc
genLibCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4592,7 +4594,7 @@ genLibCCall bid lbl_txt dsts args = do
-- | Generate C call to the given function in the RTS
genRTSCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4608,7 +4610,7 @@ genRTSCCall bid lbl_txt dsts args = do
-- | Generate a real C call to the given address with the given convention
genCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> CmmExpr
-> ForeignConvention
-> [CmmFormal]
@@ -4786,7 +4788,7 @@ genCCall32 addr _conv dest_regs args = do
call `appOL`
assign_code dest_regs)
-genCCall64 :: CmmExpr -- ^ address of function to call
+genCCall64 :: HasCallStack => CmmExpr -- ^ address of function to call
-> ForeignConvention -- ^ calling convention
-> [CmmFormal] -- ^ where to put the result
-> [CmmActual] -- ^ arguments (of mixed type)
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -63,6 +63,7 @@ import GHC.Types.Unique.Supply ( UniqueTag(..) )
import System.IO
import Data.Set (Set)
import qualified Data.Set as Set
+import GHC.Stack (HasCallStack)
{-
************************************************************************
@@ -74,7 +75,7 @@ import qualified Data.Set as Set
codeOutput
:: forall a.
- Logger
+ HasCallStack => Logger
-> TmpFs
-> LlvmConfigCache
-> DynFlags
@@ -192,7 +193,7 @@ outputC logger dflags filenm dus cmm_stream unit_deps =
************************************************************************
-}
-outputAsm :: Logger
+outputAsm :: HasCallStack => Logger
-> DynFlags
-> Module
-> ModLocation
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1941,7 +1941,7 @@ hscSimpleIface' mb_core_program tc_result summary = do
--------------------------------------------------------------
-- | Compile to hard-code.
-hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
+hscGenHardCode :: HasCallStack => HscEnv -> CgGuts -> ModLocation -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )
-- ^ @Just f@ <=> _stub.c is f
hscGenHardCode hsc_env cgguts mod_loc output_filename = do
@@ -2246,7 +2246,7 @@ generateFreshByteCodeLinkable hsc_env mod_name cgguts mod_location = do
return $ mkModuleByteCodeLinkable bco_time bco_object
------------------------------
-hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
+hscCompileCmmFile :: HasCallStack => HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
=====================================
compiler/GHC/Utils/Panic/Plain.hs
=====================================
@@ -92,12 +92,12 @@ showPlainGhcException =
. s . showString "\n\n"
. showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
-throwPlainGhcException :: PlainGhcException -> a
+throwPlainGhcException :: HasCallStack => PlainGhcException -> a
throwPlainGhcException = Exception.throw
-- | Panics and asserts.
panic, sorry, pgmError :: HasCallStack => String -> a
-panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic x)
+panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic (unlines [x, show callStack]))
sorry x = throwPlainGhcException (PlainSorry x)
pgmError x = throwPlainGhcException (PlainProgramError x)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/27297996ae63c1b1fdc5c93052cfda8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/27297996ae63c1b1fdc5c93052cfda8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/27162/ghc-codegen-panic] WIP Fix windows dynamic linking panic: genForeignCall.assign_code many
by David Eichmann (＠DavidEichmann) 16 Apr '26
by David Eichmann (＠DavidEichmann) 16 Apr '26
16 Apr '26
David Eichmann pushed to branch wip/27162/ghc-codegen-panic at Glasgow Haskell Compiler / GHC
Commits:
350c1367 by David Eichmann at 2026-04-16T16:54:31+01:00
WIP Fix windows dynamic linking panic: genForeignCall.assign_code many
- - - - -
7 changed files:
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/AArch64.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Utils/Panic/Plain.hs
Changes:
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -132,7 +132,7 @@ import System.IO
import System.Directory ( getCurrentDirectory )
--------------------
-nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle
+nativeCodeGen :: forall a . HasCallStack => Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle
-> CgStream RawCmmGroup a
-> UniqDSMT IO a
nativeCodeGen logger ts config modLoc h cmms
=====================================
compiler/GHC/CmmToAsm/AArch64.hs
=====================================
@@ -18,8 +18,9 @@ import qualified GHC.CmmToAsm.AArch64.Ppr as AArch64
import qualified GHC.CmmToAsm.AArch64.CodeGen as AArch64
import qualified GHC.CmmToAsm.AArch64.Regs as AArch64
import qualified GHC.CmmToAsm.AArch64.RegInfo as AArch64
+import GHC.Stack (HasCallStack)
-ncgAArch64 :: NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest
+ncgAArch64 :: HasCallStack => NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest
ncgAArch64 config
= NcgImpl {
ncgConfig = config
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -95,7 +95,7 @@ import GHC.Utils.Monad (mapAccumLM)
-- data GenBasicBlock i = BasicBlock BlockId [i]
cmmTopCodeGen
- :: RawCmmDecl
+ :: HasCallStack => RawCmmDecl
-> NatM [NatCmmDecl RawCmmStatics Instr]
-- Thus we'll have to deal with either CmmProc ...
@@ -123,7 +123,7 @@ cmmTopCodeGen _cmm@(CmmData sec dat) = do
return [CmmData sec dat] -- no translation, we just use CmmStatic
basicBlockCodeGen
- :: Block CmmNode C C
+ :: HasCallStack => Block CmmNode C C
-> NatM ( [NatBasicBlock Instr]
, [NatCmmDecl RawCmmStatics Instr])
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -325,7 +325,7 @@ which *are* known to change the basic block.
-- See Note [Keeping track of the current block] for why
-- we pass the BlockId.
-stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.
+stmtsToInstrs :: HasCallStack => BlockId -- ^ Basic block these statement will start to be placed in.
-> [CmmNode O O] -- ^ Cmm Statement
-> NatM (InstrBlock, BlockId) -- ^ Resulting instruction
stmtsToInstrs bid stmts =
@@ -341,7 +341,8 @@ stmtsToInstrs bid stmts =
-- | `bid` refers to the current block and is used to update the CFG
-- if new blocks are inserted in the control flow.
-- See Note [Keeping track of the current block] for more details.
-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.
+stmtToInstrs :: HasCallStack
+ => BlockId -- ^ Basic block this statement will start to be placed in.
-> CmmNode e x
-> NatM (InstrBlock, Maybe BlockId)
-- ^ Instructions, and bid of new block if successive
@@ -546,7 +547,7 @@ assignReg_I64Code (CmmLocal dst) valueTree = do
assignReg_I64Code _ _
= panic "assignReg_I64Code(i386): invalid lvalue"
-iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
+iselExpr64 :: HasCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
iselExpr64 (CmmLit (CmmInt i _)) = do
Reg64 rhi rlo <- getNewReg64
let
@@ -855,12 +856,12 @@ iselExpr64ParallelBin op e1 e2 = do
--------------------------------------------------------------------------------
-getRegister :: HasDebugCallStack => CmmExpr -> NatM Register
+getRegister :: HasCallStack => CmmExpr -> NatM Register
getRegister e = do platform <- getPlatform
is32Bit <- is32BitPlatform
getRegister' platform is32Bit e
-getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register
+getRegister' :: HasCallStack => Platform -> Bool -> CmmExpr -> NatM Register
getRegister' platform is32Bit (CmmReg reg)
= case reg of
@@ -3412,12 +3413,12 @@ intLoadCode instr mem = do
-- Compute an expression into *any* register, adding the appropriate
-- move instruction if necessary.
-getAnyReg :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock)
+getAnyReg :: HasCallStack => CmmExpr -> NatM (Reg -> InstrBlock)
getAnyReg expr = do
r <- getRegister expr
anyReg r
-anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock)
+anyReg :: HasCallStack => Register -> NatM (Reg -> InstrBlock)
anyReg (Any _ code) = return code
anyReg (Fixed rep reg fcode) = do
config <- getConfig
@@ -3426,7 +3427,7 @@ anyReg (Fixed rep reg fcode) = do
-- A bit like getSomeReg, but we want a reg that can be byte-addressed.
-- Fixed registers might not be byte-addressable, so we make sure we've
-- got a temporary, inserting an extra reg copy if necessary.
-getByteReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)
+getByteReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock)
getByteReg expr = do
config <- getConfig
is32Bit <- is32BitPlatform
@@ -3448,7 +3449,7 @@ getByteReg expr = do
-- Another variant: this time we want the result in a register that cannot
-- be modified by code to evaluate an arbitrary expression.
-getNonClobberedReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)
+getNonClobberedReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock)
getNonClobberedReg expr = do
r <- getRegister expr
config <- getConfig
@@ -4324,7 +4325,8 @@ genCondBranch' _ bid id false bool = do
-- to take/return a block id.
genForeignCall
- :: ForeignTarget -- ^ function to call
+ :: HasCallStack
+ => ForeignTarget -- ^ function to call
-> [CmmFormal] -- ^ where to put the result
-> [CmmActual] -- ^ arguments (of mixed type)
-> BlockId -- ^ The block we are in
@@ -4559,7 +4561,7 @@ loadIntoRegMightClobberOtherReg _ = True
-- | Generate C call to the given function in ghc-prim
genPrimCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4574,7 +4576,7 @@ genPrimCCall bid lbl_txt dsts args = do
-- | Generate C call to the given function in libc
genLibCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4592,7 +4594,7 @@ genLibCCall bid lbl_txt dsts args = do
-- | Generate C call to the given function in the RTS
genRTSCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4608,7 +4610,7 @@ genRTSCCall bid lbl_txt dsts args = do
-- | Generate a real C call to the given address with the given convention
genCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> CmmExpr
-> ForeignConvention
-> [CmmFormal]
@@ -4786,7 +4788,7 @@ genCCall32 addr _conv dest_regs args = do
call `appOL`
assign_code dest_regs)
-genCCall64 :: CmmExpr -- ^ address of function to call
+genCCall64 :: HasCallStack => CmmExpr -- ^ address of function to call
-> ForeignConvention -- ^ calling convention
-> [CmmFormal] -- ^ where to put the result
-> [CmmActual] -- ^ arguments (of mixed type)
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -63,6 +63,7 @@ import GHC.Types.Unique.Supply ( UniqueTag(..) )
import System.IO
import Data.Set (Set)
import qualified Data.Set as Set
+import GHC.Stack (HasCallStack)
{-
************************************************************************
@@ -74,7 +75,7 @@ import qualified Data.Set as Set
codeOutput
:: forall a.
- Logger
+ HasCallStack => Logger
-> TmpFs
-> LlvmConfigCache
-> DynFlags
@@ -192,7 +193,7 @@ outputC logger dflags filenm dus cmm_stream unit_deps =
************************************************************************
-}
-outputAsm :: Logger
+outputAsm :: HasCallStack => Logger
-> DynFlags
-> Module
-> ModLocation
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1941,7 +1941,7 @@ hscSimpleIface' mb_core_program tc_result summary = do
--------------------------------------------------------------
-- | Compile to hard-code.
-hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
+hscGenHardCode :: HasCallStack => HscEnv -> CgGuts -> ModLocation -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )
-- ^ @Just f@ <=> _stub.c is f
hscGenHardCode hsc_env cgguts mod_loc output_filename = do
@@ -2246,7 +2246,7 @@ generateFreshByteCodeLinkable hsc_env mod_name cgguts mod_location = do
return $ mkModuleByteCodeLinkable bco_time bco_object
------------------------------
-hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
+hscCompileCmmFile :: HasCallStack => HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
=====================================
compiler/GHC/Utils/Panic/Plain.hs
=====================================
@@ -92,12 +92,12 @@ showPlainGhcException =
. s . showString "\n\n"
. showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
-throwPlainGhcException :: PlainGhcException -> a
+throwPlainGhcException :: HasCallStack => PlainGhcException -> a
throwPlainGhcException = Exception.throw
-- | Panics and asserts.
panic, sorry, pgmError :: HasCallStack => String -> a
-panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic x)
+panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic (unlines [x, show callStack]))
sorry x = throwPlainGhcException (PlainSorry x)
pgmError x = throwPlainGhcException (PlainProgramError x)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/350c1367e84e3b0d9c0c2c99f14b0d4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/350c1367e84e3b0d9c0c2c99f14b0d4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/27162/ghc-codegen-panic] WIP Fix windows dynamic linking panic: genForeignCall.assign_code many
by David Eichmann (＠DavidEichmann) 16 Apr '26
by David Eichmann (＠DavidEichmann) 16 Apr '26
16 Apr '26
David Eichmann pushed to branch wip/27162/ghc-codegen-panic at Glasgow Haskell Compiler / GHC
Commits:
6d76dc08 by David Eichmann at 2026-04-16T16:44:12+01:00
WIP Fix windows dynamic linking panic: genForeignCall.assign_code many
- - - - -
2 changed files:
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Utils/Panic/Plain.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -341,7 +341,8 @@ stmtsToInstrs bid stmts =
-- | `bid` refers to the current block and is used to update the CFG
-- if new blocks are inserted in the control flow.
-- See Note [Keeping track of the current block] for more details.
-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.
+stmtToInstrs :: HasCallStack
+ => BlockId -- ^ Basic block this statement will start to be placed in.
-> CmmNode e x
-> NatM (InstrBlock, Maybe BlockId)
-- ^ Instructions, and bid of new block if successive
@@ -546,7 +547,7 @@ assignReg_I64Code (CmmLocal dst) valueTree = do
assignReg_I64Code _ _
= panic "assignReg_I64Code(i386): invalid lvalue"
-iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
+iselExpr64 :: HasCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
iselExpr64 (CmmLit (CmmInt i _)) = do
Reg64 rhi rlo <- getNewReg64
let
@@ -855,12 +856,12 @@ iselExpr64ParallelBin op e1 e2 = do
--------------------------------------------------------------------------------
-getRegister :: HasDebugCallStack => CmmExpr -> NatM Register
+getRegister :: HasCallStack => CmmExpr -> NatM Register
getRegister e = do platform <- getPlatform
is32Bit <- is32BitPlatform
getRegister' platform is32Bit e
-getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register
+getRegister' :: HasCallStack => Platform -> Bool -> CmmExpr -> NatM Register
getRegister' platform is32Bit (CmmReg reg)
= case reg of
@@ -3412,12 +3413,12 @@ intLoadCode instr mem = do
-- Compute an expression into *any* register, adding the appropriate
-- move instruction if necessary.
-getAnyReg :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock)
+getAnyReg :: HasCallStack => CmmExpr -> NatM (Reg -> InstrBlock)
getAnyReg expr = do
r <- getRegister expr
anyReg r
-anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock)
+anyReg :: HasCallStack => Register -> NatM (Reg -> InstrBlock)
anyReg (Any _ code) = return code
anyReg (Fixed rep reg fcode) = do
config <- getConfig
@@ -3426,7 +3427,7 @@ anyReg (Fixed rep reg fcode) = do
-- A bit like getSomeReg, but we want a reg that can be byte-addressed.
-- Fixed registers might not be byte-addressable, so we make sure we've
-- got a temporary, inserting an extra reg copy if necessary.
-getByteReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)
+getByteReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock)
getByteReg expr = do
config <- getConfig
is32Bit <- is32BitPlatform
@@ -3448,7 +3449,7 @@ getByteReg expr = do
-- Another variant: this time we want the result in a register that cannot
-- be modified by code to evaluate an arbitrary expression.
-getNonClobberedReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)
+getNonClobberedReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock)
getNonClobberedReg expr = do
r <- getRegister expr
config <- getConfig
@@ -4324,7 +4325,8 @@ genCondBranch' _ bid id false bool = do
-- to take/return a block id.
genForeignCall
- :: ForeignTarget -- ^ function to call
+ :: HasCallStack
+ => ForeignTarget -- ^ function to call
-> [CmmFormal] -- ^ where to put the result
-> [CmmActual] -- ^ arguments (of mixed type)
-> BlockId -- ^ The block we are in
@@ -4559,7 +4561,7 @@ loadIntoRegMightClobberOtherReg _ = True
-- | Generate C call to the given function in ghc-prim
genPrimCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4574,7 +4576,7 @@ genPrimCCall bid lbl_txt dsts args = do
-- | Generate C call to the given function in libc
genLibCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4592,7 +4594,7 @@ genLibCCall bid lbl_txt dsts args = do
-- | Generate C call to the given function in the RTS
genRTSCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4608,7 +4610,7 @@ genRTSCCall bid lbl_txt dsts args = do
-- | Generate a real C call to the given address with the given convention
genCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> CmmExpr
-> ForeignConvention
-> [CmmFormal]
@@ -4786,7 +4788,7 @@ genCCall32 addr _conv dest_regs args = do
call `appOL`
assign_code dest_regs)
-genCCall64 :: CmmExpr -- ^ address of function to call
+genCCall64 :: HasCallStack => CmmExpr -- ^ address of function to call
-> ForeignConvention -- ^ calling convention
-> [CmmFormal] -- ^ where to put the result
-> [CmmActual] -- ^ arguments (of mixed type)
=====================================
compiler/GHC/Utils/Panic/Plain.hs
=====================================
@@ -92,12 +92,12 @@ showPlainGhcException =
. s . showString "\n\n"
. showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
-throwPlainGhcException :: PlainGhcException -> a
+throwPlainGhcException :: HasCallStack => PlainGhcException -> a
throwPlainGhcException = Exception.throw
-- | Panics and asserts.
panic, sorry, pgmError :: HasCallStack => String -> a
-panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic x)
+panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic (unlines [x, show callStack]))
sorry x = throwPlainGhcException (PlainSorry x)
pgmError x = throwPlainGhcException (PlainProgramError x)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d76dc08b94544a0154a1712518904b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d76dc08b94544a0154a1712518904b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/27162/ghc-codegen-panic] WIP Fix windows dynamic linking panic: genForeignCall.assign_code many
by David Eichmann (＠DavidEichmann) 16 Apr '26
by David Eichmann (＠DavidEichmann) 16 Apr '26
16 Apr '26
David Eichmann pushed to branch wip/27162/ghc-codegen-panic at Glasgow Haskell Compiler / GHC
Commits:
a991fb06 by David Eichmann at 2026-04-16T16:33:21+01:00
WIP Fix windows dynamic linking panic: genForeignCall.assign_code many
- - - - -
2 changed files:
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Utils/Panic/Plain.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -546,7 +546,7 @@ assignReg_I64Code (CmmLocal dst) valueTree = do
assignReg_I64Code _ _
= panic "assignReg_I64Code(i386): invalid lvalue"
-iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
+iselExpr64 :: HasCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
iselExpr64 (CmmLit (CmmInt i _)) = do
Reg64 rhi rlo <- getNewReg64
let
@@ -855,12 +855,12 @@ iselExpr64ParallelBin op e1 e2 = do
--------------------------------------------------------------------------------
-getRegister :: HasDebugCallStack => CmmExpr -> NatM Register
+getRegister :: HasCallStack => CmmExpr -> NatM Register
getRegister e = do platform <- getPlatform
is32Bit <- is32BitPlatform
getRegister' platform is32Bit e
-getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register
+getRegister' :: HasCallStack => Platform -> Bool -> CmmExpr -> NatM Register
getRegister' platform is32Bit (CmmReg reg)
= case reg of
@@ -3412,12 +3412,12 @@ intLoadCode instr mem = do
-- Compute an expression into *any* register, adding the appropriate
-- move instruction if necessary.
-getAnyReg :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock)
+getAnyReg :: HasCallStack => CmmExpr -> NatM (Reg -> InstrBlock)
getAnyReg expr = do
r <- getRegister expr
anyReg r
-anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock)
+anyReg :: HasCallStack => Register -> NatM (Reg -> InstrBlock)
anyReg (Any _ code) = return code
anyReg (Fixed rep reg fcode) = do
config <- getConfig
@@ -3426,7 +3426,7 @@ anyReg (Fixed rep reg fcode) = do
-- A bit like getSomeReg, but we want a reg that can be byte-addressed.
-- Fixed registers might not be byte-addressable, so we make sure we've
-- got a temporary, inserting an extra reg copy if necessary.
-getByteReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)
+getByteReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock)
getByteReg expr = do
config <- getConfig
is32Bit <- is32BitPlatform
@@ -3448,7 +3448,7 @@ getByteReg expr = do
-- Another variant: this time we want the result in a register that cannot
-- be modified by code to evaluate an arbitrary expression.
-getNonClobberedReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)
+getNonClobberedReg :: HasCallStack => CmmExpr -> NatM (Reg, InstrBlock)
getNonClobberedReg expr = do
r <- getRegister expr
config <- getConfig
@@ -4559,7 +4559,7 @@ loadIntoRegMightClobberOtherReg _ = True
-- | Generate C call to the given function in ghc-prim
genPrimCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4574,7 +4574,7 @@ genPrimCCall bid lbl_txt dsts args = do
-- | Generate C call to the given function in libc
genLibCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4592,7 +4592,7 @@ genLibCCall bid lbl_txt dsts args = do
-- | Generate C call to the given function in the RTS
genRTSCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> FastString
-> [CmmFormal]
-> [CmmActual]
@@ -4608,7 +4608,7 @@ genRTSCCall bid lbl_txt dsts args = do
-- | Generate a real C call to the given address with the given convention
genCCall
- :: BlockId
+ :: HasCallStack => BlockId
-> CmmExpr
-> ForeignConvention
-> [CmmFormal]
@@ -4786,7 +4786,7 @@ genCCall32 addr _conv dest_regs args = do
call `appOL`
assign_code dest_regs)
-genCCall64 :: CmmExpr -- ^ address of function to call
+genCCall64 :: HasCallStack => CmmExpr -- ^ address of function to call
-> ForeignConvention -- ^ calling convention
-> [CmmFormal] -- ^ where to put the result
-> [CmmActual] -- ^ arguments (of mixed type)
=====================================
compiler/GHC/Utils/Panic/Plain.hs
=====================================
@@ -92,12 +92,12 @@ showPlainGhcException =
. s . showString "\n\n"
. showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
-throwPlainGhcException :: PlainGhcException -> a
+throwPlainGhcException :: HasCallStack => PlainGhcException -> a
throwPlainGhcException = Exception.throw
-- | Panics and asserts.
panic, sorry, pgmError :: HasCallStack => String -> a
-panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic x)
+panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic (unlines [x, show callStack]))
sorry x = throwPlainGhcException (PlainSorry x)
pgmError x = throwPlainGhcException (PlainProgramError x)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a991fb06632ab287f53a6bba62fde34…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a991fb06632ab287f53a6bba62fde34…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/27162/ghc-codegen-panic
by David Eichmann (＠DavidEichmann) 16 Apr '26
by David Eichmann (＠DavidEichmann) 16 Apr '26
16 Apr '26
David Eichmann pushed new branch wip/27162/ghc-codegen-panic at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/27162/ghc-codegen-panic
You're receiving this email because of your account on gitlab.haskell.org.
1
0