- ghc-commits - Haskell.org

[Git][ghc/ghc][master] X86 NCG: use btr/bts/btc for single-bit operations
by Marge Bot (＠marge-bot) 05 Sep '26

05 Sep '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 2908ab36 by Simon Jakobi at 2026-09-05T07:22:17-04:00 X86 NCG: use btr/bts/btc for single-bit operations Previously the Cmm patterns x & ~(1 << i) x | (1 << i) x ^ (1 << i) compiled to mov/shl/not/and-style sequences of 3-4 instructions. Now they compile to a single btr, bts or btc, matching what C compilers produce. When the bit index is a literal, constant folding has already collapsed these patterns into ones with a literal mask, such as x & 0xfffffeffffffffff for x & ~(1 << 40). Such masks are now also compiled to a bit-test instruction when they don't fit in an imm32 and would otherwise have to be loaded into a register first. For a variable bit index, this applies only when the shift is unchecked (uncheckedShiftL#, Data.Bits.unsafeShiftL): the bounds-checked shiftL used by e.g. the default clearBit/setBit/complementBit implementations wraps the shift in a bounds mask that this optimisation does not see through. With a literal index, the bounds mask is constant-folded away, so the checked operations benefit too. See Note [Bit-test instructions] in GHC.CmmToAsm.X86.CodeGen. Fixes #25233. Assisted-by: Claude Fable 5 - - - - - 9 changed files: - + changelog.d/ncg-x86-bit-test-instructions - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - + testsuite/tests/codeGen/should_gen_asm/T25233.asm - + testsuite/tests/codeGen/should_gen_asm/T25233.hs - + testsuite/tests/codeGen/should_gen_asm/T25233b.asm - + testsuite/tests/codeGen/should_gen_asm/T25233b.cmm - testsuite/tests/codeGen/should_gen_asm/all.T Changes: ===================================== changelog.d/ncg-x86-bit-test-instructions ===================================== @@ -0,0 +1,20 @@ +section: compiler +synopsis: The x86 native code generator now uses the bit-test instructions + ``btr``/``bts``/``btc`` to clear, set or complement a single bit +description: + Cmm patterns such as ``x & ~(1 << i)``, ``x | (1 << i)`` and + ``x ^ (1 << i)`` now compile to a single ``btr``/``bts``/``btc`` + instruction instead of a mov/shl/not/and-style sequence, matching what C + compilers produce. The same applies to the literal masks that constant + folding produces from these patterns when ``i`` is constant, in the cases + where the mask doesn't fit in an imm32 operand. + + For a variable bit index this applies only when the shift is unchecked, + as with ``uncheckedShiftL#`` or ``Data.Bits.unsafeShiftL``. The + bounds-checked ``shiftL`` — used, for example, by the default + implementations of ``clearBit``, ``setBit`` and ``complementBit`` — + wraps the shift in a bounds mask that this optimisation does not see + through. With a literal index, the bounds mask is constant-folded away, + so the checked operations benefit too. +mrs: !16311 +issues: #25233 ===================================== compiler/GHC/CmmToAsm/X86/CodeGen.hs ===================================== @@ -1442,6 +1442,22 @@ getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps (PUNPCKLQDQ fmt (OpReg dst) dst) ) +-- Use the bit-test instructions btr/bts/btc for clearing, setting and +-- complementing a single bit: e.g. x .&. complement (1 `shiftL` i) is btr. +-- See Note [Bit-test instructions]. +getRegister' platform is32Bit (CmmMachOp (MO_And w) [x, y]) + | bitTestOpWidthOK is32Bit w + , Just (opnd, ix) <- clearBitArgs_maybe platform w x y + = genBitTestCode (intFormat w) BTR opnd ix +getRegister' platform is32Bit (CmmMachOp (MO_Or w) [x, y]) + | bitTestOpWidthOK is32Bit w + , Just (opnd, ix) <- setBitArgs_maybe platform w x y + = genBitTestCode (intFormat w) BTS opnd ix +getRegister' platform is32Bit (CmmMachOp (MO_Xor w) [x, y]) + | bitTestOpWidthOK is32Bit w + , Just (opnd, ix) <- setBitArgs_maybe platform w x y + = genBitTestCode (intFormat w) BTC opnd ix + getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps sse4_1 <- sse4_1Enabled sse4_2 <- sse4_2Enabled @@ -5883,6 +5899,138 @@ genTrivialCode rep instr a b = do instr b_op dst return (Any rep code) +{- Note [Bit-test instructions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +x86 has dedicated instructions for clearing (btr), setting (bts) and +complementing (btc) a single bit whose index is given in a register. We use +them for Cmm patterns such as + + x & ~(1 << i) ==> btr i, x (#25233) + +replacing a mov/shl/not/and sequence with a single instruction. The +shift-count register operand of shl is masked modulo the operand width, and +the bit-offset register operand of btr/bts/btc is masked the same way, so +the replacement is faithful even for out-of-range i (where the Cmm shift is +in any case undefined). + +The bit-offset operand of these instructions must be an immediate or a +register. When the bit index is a literal, no shift reaches the NCG: +constant folding has already turned the whole mask into a literal. If that +mask fits in an imm32, we keep the ordinary and/or/xor with an immediate: +it has the same latency and better throughput (more execution ports) than +the bit-test instructions, and at worst two bytes of extra code size for bit +indices 7..30. +But a W64 mask touching the upper bits, e.g. ~(1 << 40), would have to be moved +into a register first. For such masks we recognise the folded literal itself +(exactly one bit clear resp. set) and emit btr/bts/btc with an immediate +bit offset. + +We restrict the pattern to W32 and native-width W64: the instructions do not +exist at width 8, and sub-word Cmm operations at W8/W16 are rare enough that +they are not worth the extra care. +-} + +-- | Match @1 << i@, returning @i@. +-- +-- The returned expression is always at word width ('machOpArgReps' fixes +-- shift amounts at 'wordWidth'). See Note [Bit-test instructions]. +singleBit_maybe :: CmmExpr -> Maybe CmmExpr +singleBit_maybe (CmmMachOp (MO_Shl _) [CmmLit (CmmInt 1 _), i]) = Just i +singleBit_maybe _ = Nothing + +-- | If exactly one bit of @m@, taken at width @w@, is set, return its index. +-- +-- See Note [Bit-test instructions]. +setBitLit_maybe :: Width -> Integer -> Maybe Int +setBitLit_maybe w m + | popCount m' == 1 = Just (countTrailingZeros m') + | otherwise = Nothing + where + -- w <= W64 in this X86-specific code, so a Word64 suffices. + m' = fromInteger (narrowU w m) :: Word64 + +-- | If exactly one bit of @m@, taken at width @w@, is clear, return its +-- index. +-- +-- See Note [Bit-test instructions]. +clearBitLit_maybe :: Width -> Integer -> Maybe Int +clearBitLit_maybe w m = setBitLit_maybe w (complement m) + +bitTestOpWidthOK :: Bool -> Width -> Bool +bitTestOpWidthOK is32Bit w = w == W32 || (w == W64 && not is32Bit) + +-- | The bit-offset operand of a bit-test instruction (btr/bts/btc). +data BitIndex + = BitIndexReg CmmExpr -- ^ variable index, computed into a register + | BitIndexImm Int -- ^ literal index, emitted as an immediate + +-- | Match the operands of a single-bit set or complement operation: one +-- operand is a mask @1 << i@, or a literal with exactly one bit set that +-- does not fit in an imm32. Returns the other operand and the bit index. +-- +-- Both operand orders are matched, e.g. @x | (1 << i)@ and @(1 << i) | x@. +-- +-- See Note [Bit-test instructions]. +setBitArgs_maybe :: Platform -> Width -> CmmExpr -> CmmExpr + -> Maybe (CmmExpr, BitIndex) +setBitArgs_maybe platform w x y = go x y `mplus` go y x + where + go opnd mask + | Just i <- singleBit_maybe mask + = Just (opnd, BitIndexReg i) + | CmmLit lit@(CmmInt m _) <- mask + , Just i <- setBitLit_maybe w m + , not (is32BitLit platform lit) + = Just (opnd, BitIndexImm i) + | otherwise + = Nothing + +-- | As 'setBitArgs_maybe', for a single-bit clear operation: the mask is +-- @~(1 << i)@, or a literal with exactly one bit clear. +clearBitArgs_maybe :: Platform -> Width -> CmmExpr -> CmmExpr + -> Maybe (CmmExpr, BitIndex) +clearBitArgs_maybe platform w x y = go x y `mplus` go y x + where + go opnd mask + | CmmMachOp (MO_Not _) [b] <- mask + , Just i <- singleBit_maybe b + = Just (opnd, BitIndexReg i) + | CmmLit lit@(CmmInt m _) <- mask + , Just i <- clearBitLit_maybe w m + , not (is32BitLit platform lit) + = Just (opnd, BitIndexImm i) + | otherwise + = Nothing + +-- | Generate code for @dst := x@ followed by a bit-test instruction +-- (btr/bts/btc). +-- +-- See Note [Bit-test instructions]. +genBitTestCode :: Format -> (Format -> Operand -> Operand -> Instr) + -> CmmExpr -> BitIndex -> NatM Register +genBitTestCode rep instr x (BitIndexImm i) = do + x_code <- getAnyReg x + let code dst = x_code dst `snocOL` instr rep (OpImm (ImmInt i)) (OpReg dst) + return (Any rep code) +genBitTestCode rep instr x (BitIndexReg i) = do + (i_reg, i_code) <- getNonClobberedReg i + x_code <- getAnyReg x + tmp <- getNewRegNat rep + let + -- As in genTrivialCode, 'i' must stay alive across the computation of + -- 'x' into dst, so save it in a temporary if dst holds 'i'. + code dst + | dst == i_reg = + i_code `appOL` + unitOL (MOV rep (OpReg i_reg) (OpReg tmp)) `appOL` + x_code dst `snocOL` + instr rep (OpReg tmp) (OpReg dst) + | otherwise = + i_code `appOL` + x_code dst `snocOL` + instr rep (OpReg i_reg) (OpReg dst) + return (Any rep code) + regClashesWithOp :: Reg -> Operand -> Bool reg `regClashesWithOp` OpReg reg2 = reg == reg2 reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) ===================================== compiler/GHC/CmmToAsm/X86/Instr.hs ===================================== @@ -193,6 +193,12 @@ data Instr | SHLD Format Operand{-amount-} Operand Operand | BT Format Imm Operand + -- | Bit test-and-reset + | BTR Format Operand{- ^ bit offset (imm/reg) -} Operand + -- | Bit set + | BTS Format Operand{- ^ bit offset (imm/reg) -} Operand + -- | Bit complement + | BTC Format Operand{- ^ bit offset (imm/reg) -} Operand | NOP @@ -496,6 +502,9 @@ regUsageOfInstr platform instr SHLD fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2 SHRD fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2 BT fmt _ src -> mkRUR (use_R fmt src []) + BTR fmt off dst -> usageRM fmt off dst + BTS fmt off dst -> usageRM fmt off dst + BTC fmt off dst -> usageRM fmt off dst PUSH fmt op -> mkRUR (use_R fmt op []) POP fmt op -> mkRU [] (def_W fmt op) @@ -830,6 +839,9 @@ patchRegsOfInstr platform instr env SHLD fmt imm dst1 dst2 -> patch2 (SHLD fmt imm) dst1 dst2 SHRD fmt imm dst1 dst2 -> patch2 (SHRD fmt imm) dst1 dst2 BT fmt imm src -> patch1 (BT fmt imm) src + BTR fmt off dst -> patch2 (BTR fmt) off dst + BTS fmt off dst -> patch2 (BTS fmt) off dst + BTC fmt off dst -> patch2 (BTC fmt) off dst TEST fmt src dst -> patch2 (TEST fmt) src dst CMP fmt src dst -> patch2 (CMP fmt) src dst PUSH fmt op -> patch1 (PUSH fmt) op ===================================== compiler/GHC/CmmToAsm/X86/Ppr.hs ===================================== @@ -862,6 +862,15 @@ pprInstr platform i = case i of BT format imm src -> pprFormatImmOp (text "bt") format imm src + BTR format off dst + -> pprFormatOpOp (text "btr") format off dst + + BTS format off dst + -> pprFormatOpOp (text "bts") format off dst + + BTC format off dst + -> pprFormatOpOp (text "btc") format off dst + CMP format src dst | isFloatFormat format -> pprFormatOpOp (text "ucomi") format src dst -- SSE2 | otherwise -> pprFormatOpOp (text "cmp") format src dst ===================================== testsuite/tests/codeGen/should_gen_asm/T25233.asm ===================================== @@ -0,0 +1,9 @@ +btrq +btsq +btcq +btrl +btsl +btcl +btrq $40, +btsq $40, +btcq $40, ===================================== testsuite/tests/codeGen/should_gen_asm/T25233.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE MagicHash #-} + +-- Check that clearing/setting/complementing a single, variable bit +-- uses the btr/bts/btc instructions (#25233). +module T25233 where + +import GHC.Exts + +myClearBit :: Word# -> Int# -> Word# +myClearBit x i = x `and#` not# (1## `uncheckedShiftL#` i) + +mySetBit :: Word# -> Int# -> Word# +mySetBit x i = x `or#` (1## `uncheckedShiftL#` i) + +myComplementBit :: Word# -> Int# -> Word# +myComplementBit x i = x `xor#` (1## `uncheckedShiftL#` i) + +myClearBit32 :: Word32# -> Int# -> Word32# +myClearBit32 x i = + x `andWord32#` notWord32# (wordToWord32# 1## `uncheckedShiftLWord32#` i) + +mySetBit32 :: Word32# -> Int# -> Word32# +mySetBit32 x i = x `orWord32#` (wordToWord32# 1## `uncheckedShiftLWord32#` i) + +myComplementBit32 :: Word32# -> Int# -> Word32# +myComplementBit32 x i = + x `xorWord32#` (wordToWord32# 1## `uncheckedShiftLWord32#` i) + +-- With a constant bit index >= 32, the mask constant-folds to a literal +-- that does not fit in an imm32, so a bit-test instruction with an +-- immediate offset is used. +myClearBit40 :: Word# -> Word# +myClearBit40 x = x `and#` not# (1## `uncheckedShiftL#` 40#) + +mySetBit40 :: Word# -> Word# +mySetBit40 x = x `or#` (1## `uncheckedShiftL#` 40#) + +myComplementBit40 :: Word# -> Word# +myComplementBit40 x = x `xor#` (1## `uncheckedShiftL#` 40#) ===================================== testsuite/tests/codeGen/should_gen_asm/T25233b.asm ===================================== @@ -0,0 +1,6 @@ +btrq % +btsq % +btcq % +btrq $40, +btsq $40, +btcq $40, ===================================== testsuite/tests/codeGen/should_gen_asm/T25233b.cmm ===================================== @@ -0,0 +1,27 @@ +#include "Cmm.h" + +// Single-bit masks written on the left of the operator (#25233). + +clearBitVar (W_ x, W_ i) { + return ((~((1 :: bits64) << i)) & x); +} + +setBitVar (W_ x, W_ i) { + return (((1 :: bits64) << i) | x); +} + +complementBitVar (W_ x, W_ i) { + return (((1 :: bits64) << i) ^ x); +} + +clearBit40 (W_ x) { + return ((0xFFFFFEFFFFFFFFFF :: bits64) & x); +} + +setBit40 (W_ x) { + return ((0x10000000000 :: bits64) | x); +} + +complementBit40 (W_ x) { + return ((0x10000000000 :: bits64) ^ x); +} ===================================== testsuite/tests/codeGen/should_gen_asm/all.T ===================================== @@ -23,6 +23,10 @@ test('avx512-int64-minmax', [unless(arch('x86_64'), skip), when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-mavx512vl']) test('avx512-word64-minmax', [unless(arch('x86_64'), skip), when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-mavx512vl']) +test('T25233', [unless(arch('x86_64'), skip), + when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-O']) +test('T25233b', [unless(arch('x86_64'), skip), + when(unregisterised(), skip)], compile_grep_asm, ['cmm', True, '']) is_aarch64_codegen = [ unless(arch('aarch64'), skip), when(unregisterised(), skip), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2908ab363dd269c62f07316ec2fa8f5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2908ab363dd269c62f07316ec2fa8f5… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/rafl/hpc-instances] 6 commits: hpc: Test desired HPC behaviour for class instances
by Florian Ragwitz (＠rafl) 05 Sep '26

05 Sep '26

Florian Ragwitz pushed to branch wip/rafl/hpc-instances at Glasgow Haskell Compiler / GHC Commits: cec8c909 by Florian Ragwitz at 2026-09-04T21:35:49-07:00 hpc: Test desired HPC behaviour for class instances - - - - - 7bda6078 by Florian Ragwitz at 2026-09-04T21:35:49-07:00 Extend TcGblEnv with a mapping from instance method Ids to DFunIds We want to use this in HPC to provide better support for instance methods. This is working towards #17155. - - - - - 75a32565 by Florian Ragwitz at 2026-09-04T21:36:38-07:00 hpc: Do not create top-level boxes for generated instance methods Users care about which of their written methods are or aren't covered, not whether all of the inherited methods are covered as well. Those should be covered where they are implemented. We achieve that by stopping to generate top-level boxes which will often appear as uncovered with no clear indication as to why, and no way to fix other than excercising code the user has not written. Fixes #17155. - - - - - db2f0950 by Florian Ragwitz at 2026-09-04T21:36:38-07:00 hpc: Provide coverage information for class instances After fixing #17155, we no longer create top-level boxes for the source spans of instance heads (previously that was the source span used for inherited/generated instance methods). With those boxes gone, we can introduce a new top-level box for each class instance with that instance head source span, and provide more meaningful coverage semantics for it. We make the use of any of the instance's methods (user-written or generated) tick this box, providing the programmer with useful information about whether or not the instance was exercised at run-time, and whether the instance might be unnecessary. - - - - - 6d177210 by Florian Ragwitz at 2026-09-04T21:36:38-07:00 hpc: Don't allocate boxes for methodless classes With the plumbing we currently have, these could never be covered, which is not helpful to hpc users. This could be improved upon further. - - - - - c5f3a857 by Florian Ragwitz at 2026-09-04T21:36:38-07:00 Add a changelog entry for new HPC features - - - - - 10 changed files: - + changelog.d/hpc-classinsts - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - + testsuite/tests/hpc/instmeths/instmeths.hs - + testsuite/tests/hpc/instmeths/instmeths.stdout - + testsuite/tests/hpc/instmeths/test.T Changes: ===================================== changelog.d/hpc-classinsts ===================================== @@ -0,0 +1,23 @@ +section: compiler +synopsis: Improve coverage reporting for class instances and their methods +description: + + Coverage reporting (:ghc-flag:`-fhpc`) now treats class instances more + naturally. + + Compiler-generated instance methods, such as inherited default methods, no + longer receive separate top-level coverage boxes. Explicitly implemented + instance methods retain their own declaration coverage. + + This means that it is no longer necessary to exercise all of a class' methods + in order for it to appear "covered". + + Additionally, top-level coverage boxes are now created for all instances of + classes with methods, and ticked by the use of *any* of the class' methods. + This indicates that an instance was in fact used at run-time. + + Note that classes without any instance methods are currently excluded from + this, and won't have any coverage boxes created. + +mrs: !16632 +issues: #17155 ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -147,6 +147,7 @@ deSugar hsc_env tcg_tcs = tcs, tcg_default_exports = defaults, tcg_insts = insts, + tcg_inst_meths = inst_meths, tcg_fam_insts = fam_insts, tcg_complete_matches = complete_matches, tcg_self_boot = self_boot @@ -170,7 +171,8 @@ deSugar hsc_env (hsc_logger hsc_env) (initTicksConfig (hsc_dflags hsc_env)) mod mod_loc - export_set (typeEnvTyCons type_env) binds + export_set (typeEnvTyCons type_env) + insts inst_meths binds else return (binds, Nothing) ; let modBreaks | Just (_, _, breakpointSpecs) <- m_tickInfo ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -5,7 +5,7 @@ {- (c) Galois, 2006 (c) University of Glasgow, 2007 -(c) Florian Ragwitz, 2025 +(c) Florian Ragwitz, 2025-2026 -} module GHC.HsToCore.Ticks @@ -24,6 +24,8 @@ import GHC.Unit import GHC.Core.Type import GHC.Core.TyCon +import GHC.Core.InstEnv +import GHC.Core.Class import GHC.Data.Maybe import GHC.Data.FastString @@ -56,6 +58,7 @@ import Data.Foldable (toList) import Trace.Hpc.Mix import Data.Bifunctor (second) +import Data.Functor import Data.List.NonEmpty (NonEmpty (..)) import Data.Set (Set) import qualified Data.Set as Set @@ -100,11 +103,13 @@ addTicksToBinds -- isExportedId doesn't work yet (the desugarer -- hasn't set it), so we have to work from this set. -> [TyCon] -- ^ Type constructors in this module + -> [ClsInst] + -> IdEnv DFunId -> LHsBinds GhcTc -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick, SizedSeq Tick)) addTicksToBinds logger cfg - mod mod_loc exports tyCons binds + mod mod_loc exports tyCons insts inst_meths binds | let passes = ticks_passes cfg , not (null passes) , Just orig_file <- ml_hs_file mod_loc = do @@ -129,8 +134,13 @@ addTicksToBinds logger cfg , this_mod = mod , tickishType = tickish , recSelBinds = emptyVarEnv + , instMeths = inst_meths + , instTicks = emptyVarEnv } - (binds',_,st') = unTM (addTickLHsBinds binds) env st + addTick = do + instTicks <- allocInstTicks insts + withEnv (\e -> e{ instTicks }) $ addTickLHsBinds binds + (binds',_,st') = unTM addTick env st in (binds', st') (binds1,st) = foldr tickPass (binds, initTTState) passes @@ -231,7 +241,7 @@ addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds , abs_exports = abs_exports }))) = - withEnv (add_rec_sels . add_inlines . add_exports) $ do + withEnv (add_inst_meths . add_rec_sels . add_inlines . add_exports) $ do binds' <- addTickLHsBinds binds return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' } where @@ -259,19 +269,24 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds | ABE{ abe_poly, abe_mono } <- abs_exports , RecSelId{} <- [idDetails abe_poly] ] } + add_inst_meths env = + env{ instMeths = instMeths env `extendVarEnvList` + [ (abe_mono, dfun) + | ABE{ abe_poly, abe_mono } <- abs_exports + , Just dfun <- [lookupVarEnv (instMeths env) abe_poly] ] } + addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do let name = getOccString id decl_path <- getPathEntry density <- getDensity + env <- getEnv - inline_ids <- liftM inlines getEnv -- See Note [inline sccs] let inline = isInlinePragma (idInlinePragma id) - || id `elemVarSet` inline_ids + || id `elemVarSet` inlines env -- See Note [inline sccs] - tickish <- tickishType `liftM` getEnv - case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do + case tickishType env of { ProfNotes | inline -> return (L pos funBind); _ -> do -- See Note [Record-selector ticks] selTicks <- recSelTick id @@ -294,16 +309,24 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches toplev = null decl_path exported = idName id `elemNameSet` exported_names - tick <- if not blackListed && - shouldTickBind density toplev exported simple inline + let generatedInstMeth = density == TickForCoverage + && id `elemVarEnv` instMeths env + && isGenerated (mg_origin (mg_ext matches)) + + tick <- if not generatedInstMeth + && not blackListed + && shouldTickBind density toplev exported simple inline then bindTick density name (locA pos) fvs else return Nothing + instTick <- instMethTick id + let mbCons = maybe Prelude.id (:) return $ L pos $ funBind { fun_matches = mg - , fun_ext = second (tick `mbCons`) (fun_ext funBind) } + , fun_ext = second ((instTick `mbCons`) . (tick `mbCons`)) + (fun_ext funBind) } } } where -- See Note [Record-selector ticks] @@ -1098,6 +1121,8 @@ data TickTransEnv = TTE { fileName :: FastString , this_mod :: Module , tickishType :: TickishType , recSelBinds :: IdEnv DVarSet + , instMeths :: IdEnv DFunId + , instTicks :: IdEnv CoreTickish } -- deriving Show @@ -1238,6 +1263,18 @@ isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList isBlackListed GeneratedSrcSpan{} = return False isBlackListed UnhelpfulSpan{} = return False +allocInstTicks :: [ClsInst] -> TM (IdEnv CoreTickish) +allocInstTicks insts = + ifDensity TickForCoverage (mkVarEnv . catMaybes <$> mapM alloc insts) (pure emptyVarEnv) + where + alloc ClsInst{ is_dfun, is_cls } + | null (classMethods is_cls) = pure Nothing + | otherwise = fmap (is_dfun,) <$> allocATickBox (TopLevelBox [getOccString is_dfun]) + False True (getSrcSpan is_dfun) noFVs + +instMethTick :: Id -> TM (Maybe CoreTickish) +instMethTick id = getEnv <&> \e -> lookupVarEnv (instMeths e) id >>= lookupVarEnv (instTicks e) + -- the tick application inherits the source position of its -- expression argument to support nested box allocations allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -1770,7 +1770,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; + (inst_binds, inst_meths) <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; -- Foreign exports traceTc "Tc7" empty ; @@ -1802,8 +1802,9 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, , tcg_anns = tcg_anns tcg_env ++ annotations , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls - , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; + , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] + , tcg_inst_meths = tcg_inst_meths tcg_env `plusVarEnv` inst_meths } } ; -- See Note [Newtype constructor usage in foreign declarations] addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -1282,7 +1282,7 @@ takes a slightly different approach. ********************************************************************* -} tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] - -> TcM (LHsBinds GhcTc) + -> TcM (LHsBinds GhcTc, IdEnv DFunId) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl @@ -1299,11 +1299,11 @@ tcInstDecls2 tycl_decls inst_decls -- Add the default method Ids (again) -- (they were already added in GHC.Tc.TyCl.Utils.tcAddImplicits) -- See Note [Default methods in the type environment] - ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ - mapM tcInstDecl2 inst_decls + ; (inst_binds_s, inst_meths_s) <- unzip <$> (tcExtendGlobalValEnv dm_ids $ + mapM tcInstDecl2 inst_decls) -- Done - ; return (dm_binds ++ concat inst_binds_s) } + ; return (dm_binds ++ concat inst_binds_s, plusVarEnvList inst_meths_s) } {- Note [Default methods in the type environment] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1319,12 +1319,12 @@ So right here in tcInstDecls2 we must re-extend the type envt with the default method Ids replete with their INLINE pragmas. Urk. -} -tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) +tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc, IdEnv DFunId) -- Returns a binding for the dfun tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) - = recoverM (return emptyLHsBinds) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 dfun_ty) $ + = recoverM (return (emptyLHsBinds, emptyVarEnv)) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 dfun_ty) $ do { -- Instantiate the instance decl with skolem constants (skol_info, inst_tyvars, dfun_theta, clas, inst_tys) <- tcSkolDFunType dfun_ty ; dfun_ev_vars <- newEvVars dfun_theta @@ -1342,7 +1342,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- See Note [Typechecking plan for instance declarations] ; dfun_ev_binds_var <- newTcEvBinds ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var - ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) + ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics, meth_ids)) <- pushTcLevelM $ do { (sc_ids, sc_binds, sc_implics) <- tcSuperClasses skol_info dfun_id clas inst_tyvars @@ -1356,7 +1356,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; return ( sc_ids ++ meth_ids , sc_binds ++ meth_binds - , sc_implics `unionBags` meth_implics ) } + , sc_implics `unionBags` meth_implics + , meth_ids ) } ; imp <- newImplication ; emitImplication $ @@ -1413,7 +1414,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , abs_binds = [dict_bind] , abs_sig = True } - ; return (L loc' main_bind : sc_meth_binds) + ; return (L loc' main_bind : sc_meth_binds, mkVarEnv $ (,dfun_id) <$> meth_ids) } where dfun_id = instanceDFunId ispec ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -157,6 +157,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Avail import GHC.Types.Var +import GHC.Types.Var.Env import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.SrcLoc @@ -530,6 +531,8 @@ data TcGblEnv -- NB. BangPattern is to fix a leak, see #15111 tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances -- NB. BangPattern is to fix a leak, see #15111 + tcg_inst_meths :: IdEnv DFunId, + -- ^ Maps instance method Ids to the DFunId of the instance they belong to. tcg_ann_env :: AnnEnv, -- ^ And for annotations tcg_complete_match_env :: CompleteMatches, -- ^ The complete matches for all /home-package/ modules; ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -409,6 +409,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = , tcg_knot_vars = hsc_type_env_vars hsc_env , tcg_known_key_maps = known_key_maps_var , tcg_inst_env = emptyInstEnv + , tcg_inst_meths = emptyVarEnv , tcg_fam_inst_env = emptyFamInstEnv , tcg_ann_env = emptyAnnEnv , tcg_complete_match_env = [] ===================================== testsuite/tests/hpc/instmeths/instmeths.hs ===================================== @@ -0,0 +1,57 @@ +import Data.List +import Data.Maybe +import Trace.Hpc.Mix +import Trace.Hpc.Reflect +import Trace.Hpc.Tix +import Trace.Hpc.Util + +class Foo a where + defMeth, defMeth', reqMeth :: a -> String + defMeth = const "class default" + defMeth' = const "class default" + +newtype T a = T a deriving (Show, Eq, Functor) +instance Foo (T a) where + reqMeth = const "Foo (T a) instance" + +newtype T' a = T' a + +instance Foo (T' a) where + reqMeth = const "Foo (T' a) instance" + defMeth = const "Foo (T' a) instance" + +-- no method use could "cover" this instance, so we (for now) omit the top-level box for it +class Marker a +instance Marker (T Bool) + +interesting :: (Int, MixEntry) -> Maybe (Int, HpcPos, String) +interesting (n, (pos, TopLevelBox [name])) | isInteresting name = Just (n, pos, name) + where isInteresting = (||) <$> isInst <*> isMeth + isInst = ("$f" `isPrefixOf`) + isMeth = (||) <$> (`elem` ["(==)", "(/=)", "show", "showList", "showsPrec", "fmap", "(<$)"]) + <*> ("Meth" `isSubsequenceOf`) +interesting _ = Nothing + +-- candidate for HPC.Utils, maybe? +sourceAt :: String -> HpcPos -> String +sourceAt src pos + | l1 == l2 = take (c2 - c1 + 1) . drop (c1 - 1) $ ls !! (l1 - 1) + | otherwise = intercalate "\n" $ first : (middle ++ [last]) + where + (l1, c1, l2, c2) = fromHpcPos pos + ls = lines src + first = drop (c1 - 1) $ ls !! (l1 - 1) + middle = take (l2 - l1 - 1) $ drop l1 ls + last = take c2 $ ls !! (l2 - 1) + +main :: IO () +main = do + print (T 23 == (succ <$> T 22)) -- tick Eq and Functor by using any of their methods + print (reqMeth (T' 1)) -- tick `Foo (T' a)` and that instance's `reqMeth` + + Mix source _ _ _ mixEntries <- readMix [".hpc"] (Left "Main") + src <- readFileUtf8 source + let boxes = mapMaybe interesting $ zip [0 ..] mixEntries + Tix [TixModule "Main" _ _ counts] <- examineTix + mapM_ print [ (counts !! n, path, sourceAt src pos) + | (n, pos, path) <- sortOn (\(_, _, s) -> s) boxes ] ===================================== testsuite/tests/hpc/instmeths/instmeths.stdout ===================================== @@ -0,0 +1,12 @@ +True +"Foo (T' a) instance" +(1,"$fEqT","Eq") +(0,"$fFooT","Foo (T a)") +(1,"$fFooT'","Foo (T' a)") +(1,"$fFunctorT","Functor") +(0,"$fShowT","Show") +(0,"defMeth","defMeth = const \"class default\"") +(0,"defMeth","defMeth = const \"Foo (T' a) instance\"") +(0,"defMeth'","defMeth' = const \"class default\"") +(0,"reqMeth","reqMeth = const \"Foo (T a) instance\"") +(1,"reqMeth","reqMeth = const \"Foo (T' a) instance\"") ===================================== testsuite/tests/hpc/instmeths/test.T ===================================== @@ -0,0 +1,5 @@ +setTestOpts([omit_ghci, when(fast(), skip), js_skip]) + +test('instmeths', + [ignore_extension], + compile_and_run, ['-fhpc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2d7a4cd438eca329f047a59f28d0bd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2d7a4cd438eca329f047a59f28d0bd… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/rafl/hpc-instances] 5 commits: Extend TcGblEnv with a mapping from instance method Ids to DFunIds
by Florian Ragwitz (＠rafl) 05 Sep '26

05 Sep '26

Florian Ragwitz pushed to branch wip/rafl/hpc-instances at Glasgow Haskell Compiler / GHC Commits: 4da9faec by Florian Ragwitz at 2026-09-04T21:19:21-07:00 Extend TcGblEnv with a mapping from instance method Ids to DFunIds We want to use this in HPC to provide better support for instance methods. This is working towards #17155. - - - - - f5d90d7f by Florian Ragwitz at 2026-09-04T21:19:22-07:00 hpc: Do not create top-level boxes for generated instance methods Users care about which of their written methods are or aren't covered, not whether all of the inherited methods are covered as well. Those should be covered where they are implemented. We achieve that by stopping to generate top-level boxes which will often appear as uncovered with no clear indication as to why, and no way to fix other than excercising code the user has not written. Fixes #17155. - - - - - 4a5316fb by Florian Ragwitz at 2026-09-04T21:19:22-07:00 hpc: Provide coverage information for class instances After fixing #17155, we no longer create top-level boxes for the source spans of instance heads (previously that was the source span used for inherited/generated instance methods). With those boxes gone, we can introduce a new top-level box for each class instance with that instance head source span, and provide more meaningful coverage semantics for it. We make the use of any of the instance's methods (user-written or generated) tick this box, providing the programmer with useful information about whether or not the instance was exercised at run-time, and whether the instance might be unnecessary. - - - - - 113f3d08 by Florian Ragwitz at 2026-09-04T21:19:22-07:00 hpc: Don't allocate boxes for methodless classes With the plumbing we currently have, these could never be covered, which is not helpful to hpc users. This could be improved upon further. - - - - - 2d7a4cd4 by Florian Ragwitz at 2026-09-04T21:19:22-07:00 Add a changelog entry for new HPC features - - - - - 7 changed files: - + changelog.d/hpc-classinsts - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== changelog.d/hpc-classinsts ===================================== @@ -0,0 +1,23 @@ +section: compiler +synopsis: Improve coverage reporting for class instances and their methods +description: + + Coverage reporting (:ghc-flag:`-fhpc`) now treats class instances more + naturally. + + Compiler-generated instance methods, such as inherited default methods, no + longer receive separate top-level coverage boxes. Explicitly implemented + instance methods retain their own declaration coverage. + + This means that it is no longer necessary to exercise all of a class' methods + in order for it to appear "covered". + + Additionally, top-level coverage boxes are now created for all instances of + classes with methods, and ticked by the use of *any* of the class' methods. + This indicates that an instance was in fact used at run-time. + + Note that classes without any instance methods are currently excluded from + this, and won't have any coverage boxes created. + +mrs: !16632 +issues: #17155 ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -147,6 +147,7 @@ deSugar hsc_env tcg_tcs = tcs, tcg_default_exports = defaults, tcg_insts = insts, + tcg_inst_meths = inst_meths, tcg_fam_insts = fam_insts, tcg_complete_matches = complete_matches, tcg_self_boot = self_boot @@ -170,7 +171,8 @@ deSugar hsc_env (hsc_logger hsc_env) (initTicksConfig (hsc_dflags hsc_env)) mod mod_loc - export_set (typeEnvTyCons type_env) binds + export_set (typeEnvTyCons type_env) + insts inst_meths binds else return (binds, Nothing) ; let modBreaks | Just (_, _, breakpointSpecs) <- m_tickInfo ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -5,7 +5,7 @@ {- (c) Galois, 2006 (c) University of Glasgow, 2007 -(c) Florian Ragwitz, 2025 +(c) Florian Ragwitz, 2025-2026 -} module GHC.HsToCore.Ticks @@ -24,6 +24,8 @@ import GHC.Unit import GHC.Core.Type import GHC.Core.TyCon +import GHC.Core.InstEnv +import GHC.Core.Class import GHC.Data.Maybe import GHC.Data.FastString @@ -56,6 +58,7 @@ import Data.Foldable (toList) import Trace.Hpc.Mix import Data.Bifunctor (second) +import Data.Functor import Data.List.NonEmpty (NonEmpty (..)) import Data.Set (Set) import qualified Data.Set as Set @@ -100,11 +103,13 @@ addTicksToBinds -- isExportedId doesn't work yet (the desugarer -- hasn't set it), so we have to work from this set. -> [TyCon] -- ^ Type constructors in this module + -> [ClsInst] + -> IdEnv DFunId -> LHsBinds GhcTc -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick, SizedSeq Tick)) addTicksToBinds logger cfg - mod mod_loc exports tyCons binds + mod mod_loc exports tyCons insts inst_meths binds | let passes = ticks_passes cfg , not (null passes) , Just orig_file <- ml_hs_file mod_loc = do @@ -129,8 +134,13 @@ addTicksToBinds logger cfg , this_mod = mod , tickishType = tickish , recSelBinds = emptyVarEnv + , instMeths = inst_meths + , instTicks = emptyVarEnv } - (binds',_,st') = unTM (addTickLHsBinds binds) env st + addTick = do + instTicks <- allocInstTicks insts + withEnv (\e -> e{ instTicks }) $ addTickLHsBinds binds + (binds',_,st') = unTM addTick env st in (binds', st') (binds1,st) = foldr tickPass (binds, initTTState) passes @@ -231,7 +241,7 @@ addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds , abs_exports = abs_exports }))) = - withEnv (add_rec_sels . add_inlines . add_exports) $ do + withEnv (add_inst_meths . add_rec_sels . add_inlines . add_exports) $ do binds' <- addTickLHsBinds binds return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' } where @@ -259,19 +269,24 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds | ABE{ abe_poly, abe_mono } <- abs_exports , RecSelId{} <- [idDetails abe_poly] ] } + add_inst_meths env = + env{ instMeths = instMeths env `extendVarEnvList` + [ (abe_mono, dfun) + | ABE{ abe_poly, abe_mono } <- abs_exports + , Just dfun <- [lookupVarEnv (instMeths env) abe_poly] ] } + addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do let name = getOccString id decl_path <- getPathEntry density <- getDensity + env <- getEnv - inline_ids <- liftM inlines getEnv -- See Note [inline sccs] let inline = isInlinePragma (idInlinePragma id) - || id `elemVarSet` inline_ids + || id `elemVarSet` inlines env -- See Note [inline sccs] - tickish <- tickishType `liftM` getEnv - case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do + case tickishType env of { ProfNotes | inline -> return (L pos funBind); _ -> do -- See Note [Record-selector ticks] selTicks <- recSelTick id @@ -294,16 +309,23 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches toplev = null decl_path exported = idName id `elemNameSet` exported_names - tick <- if not blackListed && - shouldTickBind density toplev exported simple inline + let generatedInstMeth = id `elemVarEnv` instMeths env + && isGenerated (mg_origin (mg_ext matches)) + + tick <- if not generatedInstMeth + && not blackListed + && shouldTickBind density toplev exported simple inline then bindTick density name (locA pos) fvs else return Nothing + instTick <- instMethTick id + let mbCons = maybe Prelude.id (:) return $ L pos $ funBind { fun_matches = mg - , fun_ext = second (tick `mbCons`) (fun_ext funBind) } + , fun_ext = second ((instTick `mbCons`) . (tick `mbCons`)) + (fun_ext funBind) } } } where -- See Note [Record-selector ticks] @@ -1098,6 +1120,8 @@ data TickTransEnv = TTE { fileName :: FastString , this_mod :: Module , tickishType :: TickishType , recSelBinds :: IdEnv DVarSet + , instMeths :: IdEnv DFunId + , instTicks :: IdEnv CoreTickish } -- deriving Show @@ -1238,6 +1262,18 @@ isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList isBlackListed GeneratedSrcSpan{} = return False isBlackListed UnhelpfulSpan{} = return False +allocInstTicks :: [ClsInst] -> TM (IdEnv CoreTickish) +allocInstTicks insts = + ifDensity TickForCoverage (mkVarEnv . catMaybes <$> mapM alloc insts) (pure emptyVarEnv) + where + alloc ClsInst{ is_dfun, is_cls } + | null (classMethods is_cls) = pure Nothing + | otherwise = fmap (is_dfun,) <$> allocATickBox (TopLevelBox [getOccString is_dfun]) + False True (getSrcSpan is_dfun) noFVs + +instMethTick :: Id -> TM (Maybe CoreTickish) +instMethTick id = getEnv <&> \e -> lookupVarEnv (instMeths e) id >>= lookupVarEnv (instTicks e) + -- the tick application inherits the source position of its -- expression argument to support nested box allocations allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -1770,7 +1770,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; + (inst_binds, inst_meths) <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; -- Foreign exports traceTc "Tc7" empty ; @@ -1802,8 +1802,9 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, , tcg_anns = tcg_anns tcg_env ++ annotations , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls - , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; + , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] + , tcg_inst_meths = tcg_inst_meths tcg_env `plusVarEnv` inst_meths } } ; -- See Note [Newtype constructor usage in foreign declarations] addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -1282,7 +1282,7 @@ takes a slightly different approach. ********************************************************************* -} tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] - -> TcM (LHsBinds GhcTc) + -> TcM (LHsBinds GhcTc, IdEnv DFunId) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl @@ -1299,11 +1299,11 @@ tcInstDecls2 tycl_decls inst_decls -- Add the default method Ids (again) -- (they were already added in GHC.Tc.TyCl.Utils.tcAddImplicits) -- See Note [Default methods in the type environment] - ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ - mapM tcInstDecl2 inst_decls + ; (inst_binds_s, inst_meths_s) <- unzip <$> (tcExtendGlobalValEnv dm_ids $ + mapM tcInstDecl2 inst_decls) -- Done - ; return (dm_binds ++ concat inst_binds_s) } + ; return (dm_binds ++ concat inst_binds_s, plusVarEnvList inst_meths_s) } {- Note [Default methods in the type environment] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1319,12 +1319,12 @@ So right here in tcInstDecls2 we must re-extend the type envt with the default method Ids replete with their INLINE pragmas. Urk. -} -tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) +tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc, IdEnv DFunId) -- Returns a binding for the dfun tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) - = recoverM (return emptyLHsBinds) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 dfun_ty) $ + = recoverM (return (emptyLHsBinds, emptyVarEnv)) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 dfun_ty) $ do { -- Instantiate the instance decl with skolem constants (skol_info, inst_tyvars, dfun_theta, clas, inst_tys) <- tcSkolDFunType dfun_ty ; dfun_ev_vars <- newEvVars dfun_theta @@ -1342,7 +1342,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- See Note [Typechecking plan for instance declarations] ; dfun_ev_binds_var <- newTcEvBinds ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var - ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) + ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics, meth_ids)) <- pushTcLevelM $ do { (sc_ids, sc_binds, sc_implics) <- tcSuperClasses skol_info dfun_id clas inst_tyvars @@ -1356,7 +1356,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; return ( sc_ids ++ meth_ids , sc_binds ++ meth_binds - , sc_implics `unionBags` meth_implics ) } + , sc_implics `unionBags` meth_implics + , meth_ids ) } ; imp <- newImplication ; emitImplication $ @@ -1413,7 +1414,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , abs_binds = [dict_bind] , abs_sig = True } - ; return (L loc' main_bind : sc_meth_binds) + ; return (L loc' main_bind : sc_meth_binds, mkVarEnv $ (,dfun_id) <$> meth_ids) } where dfun_id = instanceDFunId ispec ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -157,6 +157,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Avail import GHC.Types.Var +import GHC.Types.Var.Env import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.SrcLoc @@ -530,6 +531,8 @@ data TcGblEnv -- NB. BangPattern is to fix a leak, see #15111 tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances -- NB. BangPattern is to fix a leak, see #15111 + tcg_inst_meths :: IdEnv DFunId, + -- ^ Maps instance method Ids to the DFunId of the instance they belong to. tcg_ann_env :: AnnEnv, -- ^ And for annotations tcg_complete_match_env :: CompleteMatches, -- ^ The complete matches for all /home-package/ modules; ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -409,6 +409,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = , tcg_knot_vars = hsc_type_env_vars hsc_env , tcg_known_key_maps = known_key_maps_var , tcg_inst_env = emptyInstEnv + , tcg_inst_meths = emptyVarEnv , tcg_fam_inst_env = emptyFamInstEnv , tcg_ann_env = emptyAnnEnv , tcg_complete_match_env = [] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d4c60f391830dda7778971a8060d38… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d4c60f391830dda7778971a8060d38… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/rafl/hpc-instances] 10 commits: hpc: Test desired HPC behaviour for class instances
by Florian Ragwitz (＠rafl) 05 Sep '26

05 Sep '26

Florian Ragwitz pushed to branch wip/rafl/hpc-instances at Glasgow Haskell Compiler / GHC Commits: 40681d2c by Florian Ragwitz at 2026-09-04T18:19:40-07:00 hpc: Test desired HPC behaviour for class instances - - - - - 50d5df6d by Florian Ragwitz at 2026-09-04T18:19:40-07:00 hpc: Make instances available in TickTransEnv - - - - - 94a10668 by Florian Ragwitz at 2026-09-04T18:19:40-07:00 hpc: Capture which method Ids belong to which dictionary function Id - - - - - bb8f91e5 by Florian Ragwitz at 2026-09-04T18:19:40-07:00 hpc: Carry method id mapping in TcGblEnv - - - - - 98d4c514 by Florian Ragwitz at 2026-09-04T18:19:40-07:00 hpc: pass instance method mapping to addTicksToBinds and propagate ABEs - - - - - 1eb8f430 by Florian Ragwitz at 2026-09-04T18:19:40-07:00 hpc: Do not create top-level boxes for generated instance methods Users care about which of their written methods are or aren't covered, not whether all of the inherited methods are covered as well. Those should be covered where they are implemented. This set of changes achieves the above by stopping to generate top-level boxes which will often appear as uncovered with no clear indication as to why, and no way to fix other than excercising code the user has not written. - - - - - 988521cd by Florian Ragwitz at 2026-09-04T18:19:40-07:00 hpc: Allocate one top-level box for each class instance for coverage - - - - - 8350e6a1 by Florian Ragwitz at 2026-09-04T18:19:40-07:00 hpc: Tick top-level boxes for instances when any method is used at run-time - - - - - 9e958e61 by Florian Ragwitz at 2026-09-04T18:19:40-07:00 hpc: Don't allocate boxes for methodless classes With the plumbing we currently have, these could never be covered, which is not helpful to hpc users. This could be improved upon further. - - - - - d4c60f39 by Florian Ragwitz at 2026-09-04T18:19:40-07:00 Add a changelog entry for new HPC features - - - - - 10 changed files: - + changelog.d/hpc-classinsts - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - + testsuite/tests/hpc/instmeths/instmeths.hs - + testsuite/tests/hpc/instmeths/instmeths.stdout - + testsuite/tests/hpc/instmeths/test.T Changes: ===================================== changelog.d/hpc-classinsts ===================================== @@ -0,0 +1,23 @@ +section: compiler +synopsis: Improve coverage reporting for class instances and their methods +description: + + Coverage reporting (:ghc-flag:`-fhpc`) now treats class instances more + naturally. + + Compiler-generated instance methods, such as inherited default methods, no + longer receive separate top-level coverage boxes. Explicitly implemented + instance methods retain their own declaration coverage. + + This means that it is no longer necessary to exercise all of a class' methods + in order for it to appear "covered". + + Additionally, top-level coverage boxes are now created for all instances of + classes with methods, and ticked by the use of *any* of the class' methods. + This indicates that an instance was in fact used at run-time. + + Note that classes without any instance methods are currently excluded from + this, and won't have any coverage boxes created. + +mrs: !16632 +issues: #17155 ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -147,6 +147,7 @@ deSugar hsc_env tcg_tcs = tcs, tcg_default_exports = defaults, tcg_insts = insts, + tcg_inst_meths = inst_meths, tcg_fam_insts = fam_insts, tcg_complete_matches = complete_matches, tcg_self_boot = self_boot @@ -170,7 +171,8 @@ deSugar hsc_env (hsc_logger hsc_env) (initTicksConfig (hsc_dflags hsc_env)) mod mod_loc - export_set (typeEnvTyCons type_env) binds + export_set (typeEnvTyCons type_env) + insts inst_meths binds else return (binds, Nothing) ; let modBreaks | Just (_, _, breakpointSpecs) <- m_tickInfo ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -24,6 +24,8 @@ import GHC.Unit import GHC.Core.Type import GHC.Core.TyCon +import GHC.Core.InstEnv +import GHC.Core.Class import GHC.Data.Maybe import GHC.Data.FastString @@ -100,11 +102,13 @@ addTicksToBinds -- isExportedId doesn't work yet (the desugarer -- hasn't set it), so we have to work from this set. -> [TyCon] -- ^ Type constructors in this module + -> [ClsInst] + -> IdEnv DFunId -> LHsBinds GhcTc -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick, SizedSeq Tick)) addTicksToBinds logger cfg - mod mod_loc exports tyCons binds + mod mod_loc exports tyCons insts inst_meths binds | let passes = ticks_passes cfg , not (null passes) , Just orig_file <- ml_hs_file mod_loc = do @@ -129,8 +133,13 @@ addTicksToBinds logger cfg , this_mod = mod , tickishType = tickish , recSelBinds = emptyVarEnv + , instMeths = inst_meths + , instTicks = emptyVarEnv } - (binds',_,st') = unTM (addTickLHsBinds binds) env st + addTick = do + instTicks <- allocInstTicks insts + withEnv (\e -> e{ instTicks }) $ addTickLHsBinds binds + (binds',_,st') = unTM addTick env st in (binds', st') (binds1,st) = foldr tickPass (binds, initTTState) passes @@ -231,7 +240,7 @@ addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds , abs_exports = abs_exports }))) = - withEnv (add_rec_sels . add_inlines . add_exports) $ do + withEnv (add_inst_meths . add_rec_sels . add_inlines . add_exports) $ do binds' <- addTickLHsBinds binds return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' } where @@ -259,19 +268,26 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds | ABE{ abe_poly, abe_mono } <- abs_exports , RecSelId{} <- [idDetails abe_poly] ] } + add_inst_meths env = + env{ instMeths = instMeths env `extendVarEnvList` + [ (abe_mono, dfun) + | ABE{ abe_poly, abe_mono } <- abs_exports + , Just dfun <- [lookupVarEnv (instMeths env) abe_poly] ] } + addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do let name = getOccString id decl_path <- getPathEntry density <- getDensity + env <- getEnv - inline_ids <- liftM inlines getEnv -- See Note [inline sccs] let inline = isInlinePragma (idInlinePragma id) - || id `elemVarSet` inline_ids + || id `elemVarSet` inlines env -- See Note [inline sccs] - tickish <- tickishType `liftM` getEnv - case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do + case tickishType env of { ProfNotes | inline -> return (L pos funBind); _ -> do + + instTick <- instMethTick id -- See Note [Record-selector ticks] selTicks <- recSelTick id @@ -294,8 +310,12 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches toplev = null decl_path exported = idName id `elemNameSet` exported_names - tick <- if not blackListed && - shouldTickBind density toplev exported simple inline + let generatedInstMeth = id `elemVarEnv` instMeths env + && isGenerated (mg_origin (mg_ext matches)) + + tick <- if not generatedInstMeth + && not blackListed + && shouldTickBind density toplev exported simple inline then bindTick density name (locA pos) fvs else @@ -303,7 +323,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches let mbCons = maybe Prelude.id (:) return $ L pos $ funBind { fun_matches = mg - , fun_ext = second (tick `mbCons`) (fun_ext funBind) } + , fun_ext = second ((instTick `mbCons`) . (tick `mbCons`)) + (fun_ext funBind) } } } where -- See Note [Record-selector ticks] @@ -1098,6 +1119,8 @@ data TickTransEnv = TTE { fileName :: FastString , this_mod :: Module , tickishType :: TickishType , recSelBinds :: IdEnv DVarSet + , instMeths :: IdEnv DFunId + , instTicks :: IdEnv CoreTickish } -- deriving Show @@ -1238,6 +1261,21 @@ isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList isBlackListed GeneratedSrcSpan{} = return False isBlackListed UnhelpfulSpan{} = return False +allocInstTicks :: [ClsInst] -> TM (IdEnv CoreTickish) +allocInstTicks insts = + ifDensity TickForCoverage (mkVarEnv . catMaybes <$> mapM alloc insts) (pure emptyVarEnv) + where + alloc inst + | null (classMethods (is_cls inst)) = pure Nothing + | otherwise = do + let dfun = is_dfun inst + fmap (dfun,) <$> allocATickBox (TopLevelBox [getOccString dfun]) + False True (getSrcSpan dfun) noFVs + +instMethTick :: Id -> TM (Maybe CoreTickish) +instMethTick id = getEnv >>= \e -> + pure $ lookupVarEnv (instMeths e) id >>= lookupVarEnv (instTicks e) + -- the tick application inherits the source position of its -- expression argument to support nested box allocations allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -1770,7 +1770,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; + (inst_binds, inst_meths) <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; -- Foreign exports traceTc "Tc7" empty ; @@ -1802,8 +1802,9 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, , tcg_anns = tcg_anns tcg_env ++ annotations , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls - , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; + , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] + , tcg_inst_meths = tcg_inst_meths tcg_env `plusVarEnv` inst_meths } } ; -- See Note [Newtype constructor usage in foreign declarations] addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -1282,7 +1282,7 @@ takes a slightly different approach. ********************************************************************* -} tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] - -> TcM (LHsBinds GhcTc) + -> TcM (LHsBinds GhcTc, IdEnv DFunId) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl @@ -1299,11 +1299,11 @@ tcInstDecls2 tycl_decls inst_decls -- Add the default method Ids (again) -- (they were already added in GHC.Tc.TyCl.Utils.tcAddImplicits) -- See Note [Default methods in the type environment] - ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ - mapM tcInstDecl2 inst_decls + ; (inst_binds_s, inst_meths_s) <- unzip <$> (tcExtendGlobalValEnv dm_ids $ + mapM tcInstDecl2 inst_decls) -- Done - ; return (dm_binds ++ concat inst_binds_s) } + ; return (dm_binds ++ concat inst_binds_s, plusVarEnvList inst_meths_s) } {- Note [Default methods in the type environment] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1319,12 +1319,12 @@ So right here in tcInstDecls2 we must re-extend the type envt with the default method Ids replete with their INLINE pragmas. Urk. -} -tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) +tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc, IdEnv DFunId) -- Returns a binding for the dfun tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) - = recoverM (return emptyLHsBinds) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 dfun_ty) $ + = recoverM (return (emptyLHsBinds, emptyVarEnv)) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 dfun_ty) $ do { -- Instantiate the instance decl with skolem constants (skol_info, inst_tyvars, dfun_theta, clas, inst_tys) <- tcSkolDFunType dfun_ty ; dfun_ev_vars <- newEvVars dfun_theta @@ -1342,7 +1342,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- See Note [Typechecking plan for instance declarations] ; dfun_ev_binds_var <- newTcEvBinds ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var - ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) + ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics, meth_ids)) <- pushTcLevelM $ do { (sc_ids, sc_binds, sc_implics) <- tcSuperClasses skol_info dfun_id clas inst_tyvars @@ -1356,7 +1356,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; return ( sc_ids ++ meth_ids , sc_binds ++ meth_binds - , sc_implics `unionBags` meth_implics ) } + , sc_implics `unionBags` meth_implics + , meth_ids ) } ; imp <- newImplication ; emitImplication $ @@ -1413,7 +1414,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , abs_binds = [dict_bind] , abs_sig = True } - ; return (L loc' main_bind : sc_meth_binds) + ; return (L loc' main_bind : sc_meth_binds, mkVarEnv $ (,dfun_id) <$> meth_ids) } where dfun_id = instanceDFunId ispec ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -157,6 +157,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Avail import GHC.Types.Var +import GHC.Types.Var.Env import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.SrcLoc @@ -528,6 +529,7 @@ data TcGblEnv -- ^ Instance envt for all /home-package/ modules; -- Includes the dfuns in tcg_insts -- NB. BangPattern is to fix a leak, see #15111 + tcg_inst_meths :: IdEnv DFunId, tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances -- NB. BangPattern is to fix a leak, see #15111 tcg_ann_env :: AnnEnv, -- ^ And for annotations ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -409,6 +409,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = , tcg_knot_vars = hsc_type_env_vars hsc_env , tcg_known_key_maps = known_key_maps_var , tcg_inst_env = emptyInstEnv + , tcg_inst_meths = emptyVarEnv , tcg_fam_inst_env = emptyFamInstEnv , tcg_ann_env = emptyAnnEnv , tcg_complete_match_env = [] ===================================== testsuite/tests/hpc/instmeths/instmeths.hs ===================================== @@ -0,0 +1,58 @@ +import Data.Bifunctor +import Data.List +import Data.Maybe +import Trace.Hpc.Mix +import Trace.Hpc.Reflect +import Trace.Hpc.Tix +import Trace.Hpc.Util + +class Foo a where + defMeth, defMeth', reqMeth :: a -> String + defMeth = const "class default" + defMeth' = const "class default" + +newtype T a = T a deriving (Show, Eq, Functor) +instance Foo (T a) where + reqMeth = const "Foo (T a) instance" + +newtype T' a = T' a + +instance Foo (T' a) where + reqMeth = const "Foo (T' a) instance" + defMeth = const "Foo (T' a) instance" + +-- no method use could "cover" this instance, so we (for now) omit the top-level box for it +class Marker a +instance Marker (T Bool) + +interesting :: (Int, MixEntry) -> Maybe (Int, HpcPos, String) +interesting (n, (pos, TopLevelBox [name])) | isInteresting name = Just (n, pos, name) + where isInteresting = (||) <$> isInst <*> isMeth + isInst = ("$f" `isPrefixOf`) + isMeth = (||) <$> (`elem` ["(==)", "(/=)", "show", "showList", "showsPrec", "fmap", "(<$)"]) + <*> ("Meth" `isSubsequenceOf`) +interesting _ = Nothing + +-- candidate for HPC.Utils, maybe? +sourceAt :: String -> HpcPos -> String +sourceAt src pos + | l1 == l2 = take (c2 - c1 + 1) . drop (c1 - 1) $ ls !! (l1 - 1) + | otherwise = intercalate "\n" $ first : (middle ++ [last]) + where + (l1, c1, l2, c2) = fromHpcPos pos + ls = lines src + first = drop (c1 - 1) $ ls !! (l1 - 1) + middle = take (l2 - l1 - 1) $ drop l1 ls + last = take c2 $ ls !! (l2 - 1) + +main :: IO () +main = do + print (T 23 == (succ <$> T 22)) -- tick Eq and Functor by using any of their methods + print (reqMeth (T' 1)) -- tick `Foo (T' a)` and that instance's `reqMeth` + + Mix source _ _ _ mixEntries <- readMix [".hpc"] (Left "Main") + src <- readFileUtf8 source + let boxes = mapMaybe interesting $ zip [0 ..] mixEntries + Tix [TixModule "Main" _ _ counts] <- examineTix + mapM_ print [ (counts !! n, path, sourceAt src pos) + | (n, pos, path) <- sortOn (\(_, _, s) -> s) boxes ] ===================================== testsuite/tests/hpc/instmeths/instmeths.stdout ===================================== @@ -0,0 +1,12 @@ +True +"Foo (T' a) instance" +(1,"$fEqT","Eq") +(0,"$fFooT","Foo (T a)") +(1,"$fFooT'","Foo (T' a)") +(1,"$fFunctorT","Functor") +(0,"$fShowT","Show") +(0,"defMeth","defMeth = const \"class default\"") +(0,"defMeth","defMeth = const \"Foo (T' a) instance\"") +(0,"defMeth'","defMeth' = const \"class default\"") +(0,"reqMeth","reqMeth = const \"Foo (T a) instance\"") +(1,"reqMeth","reqMeth = const \"Foo (T' a) instance\"") ===================================== testsuite/tests/hpc/instmeths/test.T ===================================== @@ -0,0 +1,5 @@ +setTestOpts([omit_ghci, when(fast(), skip), js_skip]) + +test('instmeths', + [ignore_extension], + compile_and_run, ['-fhpc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/989054b8d826df2810e115378b3f0b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/989054b8d826df2810e115378b3f0b… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T25450-march-native] Implement -march=native for x86/x86_64
by Simon Jakobi (＠sjakobi) 05 Sep '26

05 Sep '26

Simon Jakobi pushed to branch wip/sjakobi/T25450-march-native at Glasgow Haskell Compiler / GHC Commits: cfca4580 by Simon Jakobi at 2026-09-05T00:32:47+02:00 Implement -march=native for x86/x86_64 Add a -march=native flag that probes the host CPU and enables the matching CPU-feature DynFlags, so it affects both the NCG and the LLVM backend. Detected features are folded additively into the existing flags, so explicit -m... options are never disabled. The probe is a small C shim over GCC/Clang's __builtin_cpu_supports. The deviations that remain are documented in compiler/cbits/cpu_features_x86.c. The RTS exports the runtime symbols behind the builtin (__cpu_model & co.) so GHCi's runtime linker can load the ghc library where GHCi links statically, e.g. on Windows or musl. The flag is registered in expected-undocumented-flags.txt due to #27321. Thanks to @aratamizuki for pointing out the macOS AVX-512 XSAVE quirk and for testing! Closes #25450 Assisted-by: Claude Fable 5 - - - - - 17 changed files: - + changelog.d/march-native - changelog.d/print-enabled-cpu-features - + compiler/GHC/Driver/CpuFeatures.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - + compiler/cbits/cpu_features_x86.c - compiler/ghc.cabal.in - docs/users_guide/expected-undocumented-flags.txt - docs/users_guide/using.rst - rts/RtsSymbols.c - testsuite/tests/codeGen/should_gen_asm/all.T - + testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.asm - + testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.hs - testsuite/tests/driver/all.T - + testsuite/tests/driver/march_native.stdout - + testsuite/tests/driver/march_native_additive.stdout - + testsuite/tests/driver/march_native_unsupported_arch.stderr Changes: ===================================== changelog.d/march-native ===================================== @@ -0,0 +1,12 @@ +section: compiler +synopsis: Add -march=native flag +issues: #25450 +mrs: !16126 + +description: + GHC now supports ``-march=native`` on x86 and x86_64. It probes the CPU of the + machine running GHC and enables all of the corresponding ``-m...`` CPU-feature + options automatically (such as ``-msse4.2``, ``-mavx2``, ``-mbmi2`` and + ``-mfma``), for both the native code generator and the LLVM backend. The + detected features are enabled in addition to any explicitly requested feature + flags. The flag is rejected for non-x86 targets and when cross-compiling. ===================================== changelog.d/print-enabled-cpu-features ===================================== @@ -8,9 +8,11 @@ description: prints a JSON object describing the CPU features currently enabled for code generation, together with a set of ``-m...`` flags that reproduce the effective feature set for the current target. - Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected. :: + Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected, so the flag + can also be used to inspect which features :ghc-flag:`-march=native` detected + and enabled. :: - $ ghc -mavx2 --print-enabled-cpu-features + $ ghc -march=native --print-enabled-cpu-features {"tag":"enabled-cpu-features","version":1,"target":"x86_64-linux-gnu", - "features":["SSE","SSE2","SSE3","SSSE3","SSE4.1","SSE4.2","AVX","AVX2"], - "as_m_flags":["-mavx2"]} + "features":["SSE","SSE2","SSE3","SSSE3","SSE4.1","SSE4.2","AVX","AVX2","BMI1","BMI2","FMA"], + "as_m_flags":["-mavx2","-mbmi2","-mfma"]} ===================================== compiler/GHC/Driver/CpuFeatures.hs ===================================== @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} + +module GHC.Driver.CpuFeatures + ( X86CpuFeature(..) + , cachedX86CpuFeatures + ) where + +import GHC.Prelude + +import Data.Word (Word64) +import System.IO.Unsafe (unsafePerformIO) + +-- | x86 CPU features understood by GHC's native CPU feature probe. +data X86CpuFeature + = SSE2 + | SSE3 + | SSSE3 + | SSE4_1 + | SSE4_2 + | AVX + | AVX2 + | AVX512F + | AVX512BW + | AVX512CD + | AVX512DQ + | AVX512VL + | BMI1 + | BMI2 + | FMA + | GFNI + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | Decode the bitmask returned by 'ghc_detect_x86_cpu_features'. +-- +-- Bit positions are constructor order, which must match the enum in +-- @compiler/cbits/cpu_features_x86.c@. +decodeX86CpuFeatureMask :: Word64 -> [X86CpuFeature] +decodeX86CpuFeatureMask mask = + [ feat + | feat <- [minBound .. maxBound] + , testBit mask (fromEnum feat) + ] + +-- | Low-level FFI access to the C probe. +detectX86CpuFeatureMask :: IO Word64 +#if defined(javascript_HOST_ARCH) +detectX86CpuFeatureMask = pure 0 +#else +detectX86CpuFeatureMask = c_ghc_detect_x86_cpu_features +#endif + +-- | Probe host x86 CPU features and decode them into an ordered feature list. +detectX86CpuFeatures :: IO [X86CpuFeature] +detectX86CpuFeatures = decodeX86CpuFeatureMask <$> detectX86CpuFeatureMask + +-- | The host's x86 CPU features, probed once and memoized. +cachedX86CpuFeatures :: [X86CpuFeature] +cachedX86CpuFeatures = unsafePerformIO detectX86CpuFeatures +{-# NOINLINE cachedX86CpuFeatures #-} + +#if !defined(javascript_HOST_ARCH) +foreign import ccall unsafe "ghc_detect_x86_cpu_features" + c_ghc_detect_x86_cpu_features :: IO Word64 +#endif ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -473,6 +473,8 @@ data DynFlags = DynFlags { fma :: Bool, -- ^ Enable FMA instructions. gfni :: Bool, -- ^ Enable GFNI Instructions. la664 :: Bool, -- ^ Enable LA664 instructions + marchNative :: Bool, -- ^ @-march=native@ was requested; the host + -- CPU features are applied during flag parsing. -- Constants used to control the amount of optimization done. @@ -765,6 +767,7 @@ defaultDynFlags mySettings = gfni = False, -- For LoongArch, la464 is used by default. la664 = False, + marchNative = False, maxInlineAllocSize = 128, maxInlineMemcpyInsns = 32, ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -245,6 +245,8 @@ import GHC.Platform import GHC.Platform.Ways import GHC.Platform.Profile import GHC.Platform.ArchOS +import GHC.Platform.Host (hostPlatformArch) +import qualified GHC.Driver.CpuFeatures as Cpu import GHC.Unit.Types import GHC.Unit.Parser @@ -907,8 +909,10 @@ parseDynamicFlagsFull activeFlags cmdline logger dflags0 args = do unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $ map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs + dflags1' <- applyMarchNative dflags1 + -- check for disabled flags in safe haskell - let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 + let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1' theWays = ways dflags2 unless (allowed_combination theWays) $ liftIO $ @@ -1743,6 +1747,7 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "mavx512vl" (noArg (\d -> d { avx512vl = True })) , make_ord_flag defGhcFlag "mfma" (noArg (\d -> d { fma = True })) , make_ord_flag defGhcFlag "mgfni" (noArg (\d -> d { gfni = True })) + , make_ord_flag defGhcFlag "march=native" (noArg (\d -> d { marchNative = True })) , make_ord_flag defGhcFlag "mla664" (noArg (\d -> d { la664 = True })) @@ -3826,6 +3831,53 @@ x86AsMFlags dflags = gfniFlags = [ "-mgfni" | gfni dflags ] +-- | Apply a requested @-march=native@ by probing the host CPU and enabling the +-- matching CPU-feature flags. +applyMarchNative :: MonadIO m => DynFlags -> m DynFlags +applyMarchNative dflags + | not (marchNative dflags) = return dflags + | otherwise = do + let arch = platformArch (targetPlatform dflags) + unless (arch == ArchX86 || arch == ArchX86_64) $ liftIO $ + throwGhcExceptionIO $ CmdLineError + "-march=native is only supported on x86 and x86_64 targets" + unless (arch == hostPlatformArch) $ liftIO $ + throwGhcExceptionIO $ CmdLineError + "-march=native is not supported when cross-compiling" + return (applyX86CpuFeatures Cpu.cachedX86CpuFeatures dflags) + +-- | Enable the 'DynFlags' CPU-feature fields corresponding to a probed set of +-- host x86 features. +applyX86CpuFeatures :: [Cpu.X86CpuFeature] -> DynFlags -> DynFlags +applyX86CpuFeatures feats dflags = dflags + { sseAvxVersion = foldr (max . Just) (sseAvxVersion dflags) sseLevels + , bmiVersion = foldr (max . Just) (bmiVersion dflags) bmiLevels + , avx512f = avx512f dflags || has Cpu.AVX512F + , avx512bw = avx512bw dflags || has Cpu.AVX512BW + , avx512cd = avx512cd dflags || has Cpu.AVX512CD + , avx512dq = avx512dq dflags || has Cpu.AVX512DQ + , avx512vl = avx512vl dflags || has Cpu.AVX512VL + , fma = fma dflags || has Cpu.FMA + , gfni = gfni dflags || has Cpu.GFNI + } + where + has feat = feat `elem` feats + sseLevels = [ lvl | feat <- feats, Just lvl <- [sseLevelOf feat] ] + bmiLevels = [ lvl | feat <- feats, Just lvl <- [bmiLevelOf feat] ] + sseLevelOf feat = case feat of + Cpu.SSE2 -> Just SSE2 + Cpu.SSE3 -> Just SSE3 + Cpu.SSSE3 -> Just SSSE3 + Cpu.SSE4_1 -> Just SSE4 + Cpu.SSE4_2 -> Just SSE42 + Cpu.AVX -> Just AVX1 + Cpu.AVX2 -> Just AVX2 + _ -> Nothing + bmiLevelOf feat = case feat of + Cpu.BMI1 -> Just BMI1 + Cpu.BMI2 -> Just BMI2 + _ -> Nothing + -- | Query if the target RTS has the given 'Ways'. It's computed from -- the @"RTS ways"@ field in the settings file. targetHasRTSWays :: DynFlags -> Ways -> Bool ===================================== compiler/cbits/cpu_features_x86.c ===================================== @@ -0,0 +1,97 @@ +#include <HsFFI.h> + +/* Runtime x86 CPU feature detection backing GHC.Driver.CpuFeatures + (-march=native). + + The bit positions in the returned mask are GHC's own; the enum below + must match the constructor order of X86CpuFeature in + GHC.Driver.CpuFeatures. + + The __builtin_cpu_* calls below compile to references to libgcc/compiler-rt + symbols (__cpu_model & co.), which GHCi's runtime linker can only resolve + because the RTS exports them: see RTS_X86_CPU_MODEL_SYMBOLS in + rts/RtsSymbols.c and keep its guards in sync with this file's. */ + +enum { + GHC_X86_FEAT_SSE2 = 0, + GHC_X86_FEAT_SSE3, + GHC_X86_FEAT_SSSE3, + GHC_X86_FEAT_SSE4_1, + GHC_X86_FEAT_SSE4_2, + GHC_X86_FEAT_AVX, + GHC_X86_FEAT_AVX2, + GHC_X86_FEAT_AVX512F, + GHC_X86_FEAT_AVX512BW, + GHC_X86_FEAT_AVX512CD, + GHC_X86_FEAT_AVX512DQ, + GHC_X86_FEAT_AVX512VL, + GHC_X86_FEAT_BMI1, + GHC_X86_FEAT_BMI2, + GHC_X86_FEAT_FMA, + GHC_X86_FEAT_GFNI +}; + +#if (defined(__i386__) || defined(__x86_64__)) \ + && (defined(__GNUC__) || defined(__clang__)) + +/* GFNI joined the __builtin_cpu_supports feature lists later than the + other features here (GCC 11; compiler-rt's cpu_model in LLVM 12). + Under an older bootstrap compiler we conservatively report no GFNI. */ +#if (defined(__clang_major__) && __clang_major__ >= 12) \ + || (!defined(__clang__) && defined(__GNUC__) && __GNUC__ >= 11) +#define GHC_HAS_CPU_SUPPORTS_GFNI 1 +#else +#define GHC_HAS_CPU_SUPPORTS_GFNI 0 +#endif + +HsWord64 ghc_detect_x86_cpu_features(void) +{ + __builtin_cpu_init(); + + HsWord64 feats = 0; + + /* __builtin_cpu_supports returns the feature's (nonzero) mask bit, + not 0/1, so it must be normalized before shifting. */ +#define GHC_CPU_FEATURE(name, bit) \ + if (__builtin_cpu_supports(name)) { feats |= ((HsWord64)1 << (bit)); } + + GHC_CPU_FEATURE("sse2", GHC_X86_FEAT_SSE2) + GHC_CPU_FEATURE("sse3", GHC_X86_FEAT_SSE3) + GHC_CPU_FEATURE("ssse3", GHC_X86_FEAT_SSSE3) + GHC_CPU_FEATURE("sse4.1", GHC_X86_FEAT_SSE4_1) + GHC_CPU_FEATURE("sse4.2", GHC_X86_FEAT_SSE4_2) + GHC_CPU_FEATURE("avx", GHC_X86_FEAT_AVX) + GHC_CPU_FEATURE("avx2", GHC_X86_FEAT_AVX2) + GHC_CPU_FEATURE("avx512f", GHC_X86_FEAT_AVX512F) + GHC_CPU_FEATURE("avx512bw", GHC_X86_FEAT_AVX512BW) + GHC_CPU_FEATURE("avx512cd", GHC_X86_FEAT_AVX512CD) + GHC_CPU_FEATURE("avx512dq", GHC_X86_FEAT_AVX512DQ) + GHC_CPU_FEATURE("avx512vl", GHC_X86_FEAT_AVX512VL) + GHC_CPU_FEATURE("bmi", GHC_X86_FEAT_BMI1) + GHC_CPU_FEATURE("bmi2", GHC_X86_FEAT_BMI2) + + /* FMA is usable only when the OS saves the AVX register state. However + compiler-rt's cpu_model/x86.c reports "fma" from the raw CPUID bit. */ + if (__builtin_cpu_supports("fma") && __builtin_cpu_supports("avx")) { + feats |= ((HsWord64)1 << GHC_X86_FEAT_FMA); + } + +#if GHC_HAS_CPU_SUPPORTS_GFNI + GHC_CPU_FEATURE("gfni", GHC_X86_FEAT_GFNI) +#endif + +#undef GHC_CPU_FEATURE + + return feats; +} + +#else + +/* Non-x86 host, or a compiler without __builtin_cpu_supports (e.g. MSVC): + report no features. */ +HsWord64 ghc_detect_x86_cpu_features(void) +{ + return 0; +} + +#endif ===================================== compiler/ghc.cabal.in ===================================== @@ -187,6 +187,7 @@ Library else c-sources: cbits/cutils.c + cbits/cpu_features_x86.c cbits/genSym.c cbits/keepCAFsForGHCi.c @@ -518,6 +519,7 @@ Library GHC.Driver.Config.StgToCmm GHC.Driver.Config.Tidy GHC.Driver.Config.StgToJS + GHC.Driver.CpuFeatures GHC.Driver.DynFlags GHC.Driver.IncludeSpecs GHC.Driver.Downsweep ===================================== docs/users_guide/expected-undocumented-flags.txt ===================================== @@ -74,6 +74,7 @@ -instantiated-with -keep-hi-file -keep-o-file +-march=native -n -no-keep-hi-file -no-keep-o-file ===================================== docs/users_guide/using.rst ===================================== @@ -539,7 +539,9 @@ The available mode flags are: Print a JSON object describing the CPU features currently enabled for code generation, together with a set of ``-m...`` flags that reproduce the effective feature set for the current target. - Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected. + Dynamic options such as ``-mavx2`` and ``-mbmi2`` are respected, so this flag + can also be used to inspect which features :ghc-flag:`-march=native` detected + and enabled. .. ghc-flag:: --print-debug-on :shortdesc: print whether GHC was built with ``-DDEBUG`` @@ -1897,6 +1899,34 @@ Some flags only make sense for particular target platforms. so this flag has no effect when used with the :ref:`native code generator <native-code-gen>` or the :ref:`LLVM backend <llvm-code-gen>`. +.. ghc-flag:: -march=native + :shortdesc: (x86 only) Enable all CPU features supported by the host + :type: dynamic + :category: platform-options + + (x86/x86_64 only) Probe the CPU of the machine running GHC and enable all of + the corresponding ``-m...`` CPU-feature options automatically (for example + ``-msse4.2``, ``-mavx2``, ``-mbmi2``, ``-mfma``). The detected features apply + to both the :ref:`native code generator <native-code-gen>` and the + :ref:`LLVM backend <llvm-code-gen>`. + + The detected features are enabled *in addition* to any CPU-feature flags you + pass explicitly, regardless of their order on the command line; ``-march=native`` + never disables a feature. + + The features that were detected and enabled can be inspected with + :ghc-flag:`--print-enabled-cpu-features`. + + .. warning:: + + Code compiled with ``-march=native`` may use instructions that are not + available on other CPUs, and is therefore not portable to a different + machine. + + Only x86 and x86_64 targets are supported so far; the flag is rejected on + other targets. It is also rejected when cross-compiling, since the host CPU + is then unrelated to the target. + Haddock ------- ===================================== rts/RtsSymbols.c ===================================== @@ -1039,6 +1039,30 @@ extern char **environ; #define RTS_ARM_OUTLINE_ATOMIC_SYMBOLS #endif +// libgcc/compiler-rt symbols behind __builtin_cpu_supports/__builtin_cpu_init, +// referenced by compiler/cbits/cpu_features_x86.c (-march=native). +// Without them the runtime linker cannot load the ghc library's object code +// (e.g. for plugins in a statically linked GHCi). Keep the guards in sync +// with cpu_features_x86.c. +#if (defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)) \ + && (defined(__GNUC__) || defined(__clang__)) +// __cpu_features2 holds the feature words beyond the first 32 (e.g. GFNI) +// and only exists in the runtimes of GCC >= 11 resp. LLVM >= 12. +#if (defined(__clang_major__) && __clang_major__ >= 12) \ + || (!defined(__clang__) && defined(__GNUC__) && __GNUC__ >= 11) +#define RTS_X86_CPU_FEATURES2_SYMBOLS \ + SymI_NeedsDataProto(__cpu_features2) +#else +#define RTS_X86_CPU_FEATURES2_SYMBOLS +#endif +#define RTS_X86_CPU_MODEL_SYMBOLS \ + SymI_NeedsProto(__cpu_indicator_init) \ + SymI_NeedsDataProto(__cpu_model) \ + RTS_X86_CPU_FEATURES2_SYMBOLS +#else +#define RTS_X86_CPU_MODEL_SYMBOLS +#endif + // Symbols defined by libc #define RTS_LIBC_SYMBOLS \ SymI_HasProto_redirect(atexit, atexit, STRENGTH_STRONG, SYM_TYPE_CODE) /* See Note [Strong symbols] */ \ @@ -1199,6 +1223,7 @@ RTS_OPENBSD_ONLY_SYMBOLS RTS_LIBC_SYMBOLS RTS_LIBGCC_SYMBOLS RTS_ARCH_LIBGCC_SYMBOLS +RTS_X86_CPU_MODEL_SYMBOLS RTS_FINI_ARRAY_SYMBOLS RTS_LIBFFI_SYMBOLS RTS_ARM_OUTLINE_ATOMIC_SYMBOLS @@ -1254,6 +1279,7 @@ void initLinkerRtsSyms (StrHashTable *symhash) { RTS_OPENBSD_ONLY_SYMBOLS RTS_LIBGCC_SYMBOLS RTS_ARCH_LIBGCC_SYMBOLS + RTS_X86_CPU_MODEL_SYMBOLS RTS_FINI_ARRAY_SYMBOLS RTS_LIBFFI_SYMBOLS RTS_ARM_OUTLINE_ATOMIC_SYMBOLS ===================================== testsuite/tests/codeGen/should_gen_asm/all.T ===================================== @@ -17,6 +17,11 @@ test('msse-option-order', [unless(arch('x86_64') or arch('i386'), skip), when(unregisterised(), skip)], compile_grep_asm, ['hs', False, '-msse4.2 -msse2']) test('mavx-should-enable-popcnt', [unless(arch('x86_64') or arch('i386'), skip), when(unregisterised(), skip)], compile_grep_asm, ['hs', False, '-mavx']) +# -march=native probes the host CPU, so gate on the host actually having SSE4.2 +# (have_cpu_feature reports nothing under cross, skipping the test there too). +test('march-native-enables-popcnt', + [unless((arch('x86_64') or arch('i386')) and have_cpu_feature('sse4_2'), skip), + when(unregisterised(), skip)], compile_grep_asm, ['hs', False, '-march=native']) test('avx512-int64-mul', [unless(arch('x86_64'), skip), when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-mavx512dq -mavx512vl']) test('avx512-int64-minmax', [unless(arch('x86_64'), skip), ===================================== testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.asm ===================================== @@ -0,0 +1 @@ +popcnt(?![0-9]) \ No newline at end of file ===================================== testsuite/tests/codeGen/should_gen_asm/march-native-enables-popcnt.hs ===================================== @@ -0,0 +1,11 @@ +-- `-march=native` enables the host's CPU features. On a host with SSE4.2 +-- (gated in all.T via have_cpu_feature) this makes popCount compile to a +-- `popcnt` instruction rather than the SSE2-baseline software fallback. +import Data.Bits + +{-# NOINLINE foo #-} +foo :: Int -> Int +foo x = 1 + popCount x + +main :: IO () +main = print (foo 42) ===================================== testsuite/tests/driver/all.T ===================================== @@ -7,6 +7,12 @@ def normalise_unknown_flag(msg): m = re.search(r'unrecognised flag: \S+', msg) return m.group(0) + '\n' if m else msg +def normalise_march_native_error(msg): + # Keep only the stable '-march=native ...' diagnostic; the program-name + # prefix and any usage trailer vary across configurations. + m = re.search(r'-march=native is [^\n]+', msg) + return m.group(0) + '\n' if m else msg + test('driver011', [extra_files(['A011.hs'])], makefile_test, ['test011']) test('driver012', [extra_files(['A012.hs'])], makefile_test, ['test012']) @@ -265,6 +271,29 @@ test('print_enabled_cpu_features_unknown_flag', run_command, ['{compiler} -mavx22 --print-enabled-cpu-features']) +# -march=native enables at least the x86_64 baseline (SSE2). The full feature +# set is host-dependent, so we only assert the always-present baseline. +test('march_native', + [unless(arch('x86_64') or arch('i386'), skip)], + run_command, + ['{compiler} -march=native --print-enabled-cpu-features | grep -o SSE2']) + +# On non-x86 targets -march=native must be rejected. +test('march_native_unsupported_arch', + [when(arch('x86_64') or arch('i386'), skip), + normalise_errmsg_fun(normalise_march_native_error), exit_code(1)], + run_command, + ['{compiler} -march=native --print-enabled-cpu-features']) + +# -march=native is additive with explicit -m flags, regardless of order: an +# explicitly requested feature (here AVX2, forced on independent of the host) is +# still present whether the flag comes before or after -march=native. +test('march_native_additive', + [unless(arch('x86_64') or arch('i386'), skip)], + run_command, + ['{compiler} -mavx2 -march=native --print-enabled-cpu-features | grep -o AVX2 && ' + '{compiler} -march=native -mavx2 --print-enabled-cpu-features | grep -o AVX2']) + test('T10219', normal, run_command, # `-x hspp` in make mode should work. # Note: need to specify `-x hspp` before the filename. ===================================== testsuite/tests/driver/march_native.stdout ===================================== @@ -0,0 +1 @@ +SSE2 ===================================== testsuite/tests/driver/march_native_additive.stdout ===================================== @@ -0,0 +1,2 @@ +AVX2 +AVX2 ===================================== testsuite/tests/driver/march_native_unsupported_arch.stderr ===================================== @@ -0,0 +1 @@ +-march=native is only supported on x86 and x86_64 targets View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cfca4580536b7bc4dd9713bec527844… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cfca4580536b7bc4dd9713bec527844… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/rafl/hpc-instances] Add a changelog entry for new HPC features
by Florian Ragwitz (＠rafl) 05 Sep '26

05 Sep '26

Florian Ragwitz pushed to branch wip/rafl/hpc-instances at Glasgow Haskell Compiler / GHC Commits: 989054b8 by Florian Ragwitz at 2026-09-04T12:52:35-07:00 Add a changelog entry for new HPC features - - - - - 1 changed file: - + changelog.d/hpc-classinsts Changes: ===================================== changelog.d/hpc-classinsts ===================================== @@ -0,0 +1,23 @@ +section: compiler +synopsis: Improve coverage reporting for class instances and their methods +description: + + Coverage reporting (:ghc-flag:`-fhpc`) now treats class instances more + naturally. + + Compiler-generated instance methods, such as inherited default methods, no + longer receive separate top-level coverage boxes. Explicitly implemented + instance methods retain their own declaration coverage. + + This means that it is no longer necessary to exercise all of a class' methods + in order for it to appear "covered". + + Additionally, top-level coverage boxes are now created for all instances of + classes with methods, and ticked by the use of *any* of the class' methods. + This indicates that an instance was in fact used at run-time. + + Note that classes without any instance methods are currently excluded from + this, and won't have any coverage boxes created. + +mrs: !16632 +issues: #17155 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/989054b8d826df2810e115378b3f0b0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/989054b8d826df2810e115378b3f0b0… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/rafl/hpc-instances] 13 commits: Add -Wimplicit-field-strictness (#16836)
by Florian Ragwitz (＠rafl) 05 Sep '26

05 Sep '26

Florian Ragwitz pushed to branch wip/rafl/hpc-instances at Glasgow Haskell Compiler / GHC Commits: 9e7739ab by Simon Jakobi at 2026-09-03T13:45:43-04:00 Add -Wimplicit-field-strictness (#16836) This opt-in warning fires when a data constructor field lacks an explicit strictness annotation (`!` or `~`). It complements the LazyFieldAnnotations extension (4762a8bf30f) from GHC proposal 752, which makes `~` annotations available for this purpose. Deciding which fields to report requires their levity, so the check runs after typechecking. To keep the noise down, the diagnostic is emitted once per data declaration, grouped by constructor. Closes #16836. Assisted-by: Claude Fable 5 - - - - - 6a44d591 by mangoiv at 2026-09-03T13:46:22-04:00 simplifier: remove a bogus `assert` in `rebuild_app'` in `GHC.CoreToStg.Prep.cpeApp`. Prior to this commit commit 08bc245be70d95801bc1138804ed1de9474fbdc0 Author: sheaf <sam.derbyshire(a)gmail.com> Date: Sat Feb 28 16:30:43 2026 +0100 Clean up join points, casts & ticks This commit shores up the logic dealing with casts and ticks occurring in between a join point binding and a jump any `PlaceRuntime` ticks we observed were profiling ticks, even though that isn't necessary. The more liberal rules in the above commit allow e.g. breakpoint ticks (which are valid PlaceRuntime ticks) to legitimately appear in an argument position. Fixes #27556 - - - - - eaa95a6f by Andrei Borzenkov at 2026-09-04T08:08:40-04:00 Parentheses in prefix GADT constructors (#27423) Updated `splitLHsGadtTy` to allow looking through the parentheses for inner binders. General example of a code pattern that's allowed now: data S a where MkS :: (forall a. S a) That should work now with any combination of nested foralls and parentheses. We don't perform parenthesis unwrapping for record GADT constructors in accordance with GHC Proposal #402. To this end `con_inner_bndrs` no longer stores plain forall telescopes: `[HsForAllTelescope pass]` is replaced with `[LHsGadtTelescope pass]`, a new `HsArg`-style type whose `HsGadtForAll` holds an inner telescope and whose `HsGadtPar` holds a pair of parentheses. The parentheses carry no meaning for renaming or type checking; the only reason to record them is exact-printing. Updated `pprConDecl` to improve the `parse == parse . ppr . parse` property of GADT pretty-printing. The pretty printer can now output code that's similar to this: data T a where MkT1 :: (forall a. T a) MkT2 :: forall . forall a. T a These are special cases of inner forall binders for prefix GADT constructors, when we have either implicit or zero explicit outer binders. - - - - - 639456a8 by Evgeny Malyshev at 2026-09-04T08:09:25-04:00 HsPat: Add spacing to unary tuple patterns Use hsep when printing unary boxed TuplePat applications so that the MkSolo constructor is separated from its argument. The old hcat rendered wildcard and parenthesized arguments as MkSolo_ and MkSolo(). Add T27034 to exercise the HsPat splice-dump path with wildcard and variable arguments, and update existing affected golden output. Fixes #27034 Assisted-By: OpenAI Codex - - - - - 866efbe1 by Florian Ragwitz at 2026-09-04T12:33:44-07:00 hpc: Test desired HPC behaviour for class instances - - - - - 14ec4671 by Florian Ragwitz at 2026-09-04T12:33:44-07:00 hpc: Make instances available in TickTransEnv - - - - - 3a888eb6 by Florian Ragwitz at 2026-09-04T12:33:44-07:00 hpc: Capture which method Ids belong to which dictionary function Id - - - - - e88eb168 by Florian Ragwitz at 2026-09-04T12:33:44-07:00 hpc: Carry method id mapping in TcGblEnv - - - - - 57ec525b by Florian Ragwitz at 2026-09-04T12:33:44-07:00 hpc: pass instance method mapping to addTicksToBinds and propagate ABEs - - - - - 1852aeef by Florian Ragwitz at 2026-09-04T12:33:44-07:00 hpc: Do not create top-level boxes for generated instance methods Users care about which of their written methods are or aren't covered, not whether all of the inherited methods are covered as well. Those should be covered where they are implemented. This set of changes achieves the above by stopping to generate top-level boxes which will often appear as uncovered with no clear indication as to why, and no way to fix other than excercising code the user has not written. - - - - - 7bc54197 by Florian Ragwitz at 2026-09-04T12:33:45-07:00 hpc: Allocate one top-level box for each class instance for coverage - - - - - 37739055 by Florian Ragwitz at 2026-09-04T12:33:45-07:00 hpc: Tick top-level boxes for instances when any method is used at run-time - - - - - da64ce47 by Florian Ragwitz at 2026-09-04T12:33:45-07:00 hpc: Don't allocate boxes for methodless classes With the plumbing we currently have, these could never be covered, which is not helpful to hpc users. This could be improved upon further. - - - - - 70 changed files: - + changelog.d/27556 - + changelog.d/allow-gadt-prefix-con-parens - + changelog.d/implicit-field-strictness-warning - changelog.d/lazy-field-annotations - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Tickish.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Type.hs - docs/users_guide/exts/gadt_syntax.rst - docs/users_guide/exts/strict.rst - docs/users_guide/using-warnings.rst - − testsuite/tests/gadt/T14320.stderr - testsuite/tests/gadt/T18191.hs - testsuite/tests/gadt/T18191.stderr - + testsuite/tests/gadt/T27423a.hs - + testsuite/tests/gadt/T27423b.hs - + testsuite/tests/gadt/T27423b.stderr - testsuite/tests/gadt/all.T - + testsuite/tests/hpc/instmeths/instmeths.hs - + testsuite/tests/hpc/instmeths/instmeths.stdout - + testsuite/tests/hpc/instmeths/test.T - testsuite/tests/printer/Makefile - + testsuite/tests/printer/T27423c.hs - testsuite/tests/printer/all.T - + testsuite/tests/simplCore/should_compile/T27556.hs - + testsuite/tests/simplCore/should_compile/T27556.script - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/th/T17380.stderr - testsuite/tests/th/T18612.stderr - + testsuite/tests/th/T27034.hs - + testsuite/tests/th/T27034.stderr - testsuite/tests/th/T8761.stderr - testsuite/tests/th/all.T - + testsuite/tests/warnings/should_compile/T16836a.hs - + testsuite/tests/warnings/should_compile/T16836a.stderr - + testsuite/tests/warnings/should_compile/T16836b.hs - + testsuite/tests/warnings/should_compile/T16836c.hs - + testsuite/tests/warnings/should_compile/T16836c.stderr - + testsuite/tests/warnings/should_compile/T16836d.hs - + testsuite/tests/warnings/should_compile/T16836d.stderr - testsuite/tests/warnings/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46aeba43193a1399ef9c93387abe25… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46aeba43193a1399ef9c93387abe25… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/multi-threaded-debugger] fixes
by Rodrigo Mesquita (＠alt-romes) 05 Sep '26

05 Sep '26

Rodrigo Mesquita pushed to branch wip/romes/multi-threaded-debugger at Glasgow Haskell Compiler / GHC Commits: 252c2664 by Rodrigo Mesquita at 2026-09-04T19:25:54+01:00 fixes - - - - - 1 changed file: - compiler/GHC/Runtime/Eval.hs Changes: ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -136,7 +136,6 @@ import Data.List.NonEmpty (NonEmpty) import Unsafe.Coerce ( unsafeCoerce ) import qualified GHC.Unit.Home.Graph as HUG import GHCi.BreakArray (BreakArray) -import Data.Either (fromRight) -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -315,8 +314,10 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do final_names = map getName final_ids liftIO $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip final_names hvals) hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} + let improved_final_ids = -- the final_ids are at the head of hsc_IC + take (length final_ids) [ i | AnId i <- ic_tythings (hsc_IC hsc_env') ] setSession hsc_env' - return (ExecComplete (Right final_ids {- TODO: THESE MUST BE IMPROVED BEFORE RETURNED -}) allocs) + return (ExecComplete (Right improved_final_ids) allocs) -- Completed with an exception EvalComplete alloc (EvalException e) -> @@ -327,7 +328,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref let span = mkGeneralSrcSpan (fsLit "<unknown>") - (hsc_env1, names) <- liftIO $ + (hsc_env1, break_ids) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack_fhv span Nothing let resume = Resume @@ -346,7 +347,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do hsc_env2 = pushResume hsc_env1 resume setSession hsc_env2 - return (ExecBreak final_ids Nothing resume) + return (ExecBreak break_ids Nothing resume) -- EvalBreak (Just ...) case: the interpreter stopped at a breakpoint -- @@ -374,7 +375,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do -- This function only returns control to ghci with 'ExecBreak' when it is really meant to break. -- Specifically, for :steplocal or :stepmodule, don't return control -- and simply resume execution from here until we hit a breakpoint we do want to stop at. - (hsc_env1, final_ids) <- liftIO $ + (hsc_env1, break_ids) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) let resume = Resume @@ -392,7 +393,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do } hsc_env2 = pushResume hsc_env1 resume setSession hsc_env2 - return (ExecBreak final_ids (Just ibi) resume) + return (ExecBreak break_ids (Just ibi) resume) else do -- resume with the same step type let eval_opts = (initEvalOpts dflags (enableGhcStepMode step)) @@ -645,7 +646,9 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip names fhvs) when result_ok $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(result_name, apStack_fhv)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, final_ids {-TODO: IMPROVE RTTI -}) + let improved_final_ids = -- the final_ids are at the head of hsc_IC + take (length final_ids) [ i | AnId i <- ic_tythings (hsc_IC hsc_env1) ] + return (hsc_env1, improved_final_ids) where -- We need a fresh Unique for each Id we bind, because the linker -- state is single-threaded and otherwise we'd spam old bindings View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/252c2664913c7b53b83b3cc70249ec0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/252c2664913c7b53b83b3cc70249ec0… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/multi-threaded-debugger] 4 commits: move to GHCi.Run.Breakpoints
by Rodrigo Mesquita (＠alt-romes) 05 Sep '26

05 Sep '26

Rodrigo Mesquita pushed to branch wip/romes/multi-threaded-debugger at Glasgow Haskell Compiler / GHC Commits: b7aee273 by Rodrigo Mesquita at 2026-09-04T10:39:49+01:00 move to GHCi.Run.Breakpoints - - - - - 8dafed3e by Rodrigo Mesquita at 2026-09-04T17:10:33+01:00 Refactor: we have the interactive Ids directly... clean up significantly Removes things like names <- map idName ids map (\i -> let id = find (\x -> i==idName x) names) idso and is more straightforward because there's less state going around (no more updating HscEnv as an output) It also kills `printTypeOfNames` completely, since now we just have the Ids. No longer `lookupName` names to get back the ids... ``` printTypeOfName :: GHC.GhcMonad m => Name -> m () printTypeOfName n = do maybe_tything <- GHC.lookupName n case maybe_tything of Nothing -> return () Just thing -> printTyThing thing ``` now is just `printTyThing . AnId` Also: ```diff - tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted - docs <- mapM pprTypeAndContents [i | AnId i <- tythings] + docs <- mapM pprTypeAndContents idsSorted ``` (and yes, in ExecBreaks there are only Ids, no TyThings, bc they are only constructed by the interpreter execution which can only bind ids. for TyThings use runDecls which doesn't return execBreaks.) I have a plan for the `resumes`, I'm getting there. Put the resume in ExecBreak fixes grrr - - - - - c43cb731 by Rodrigo Mesquita at 2026-09-04T17:29:40+01:00 UNDO the removing-hsc-env-globality part of the clean up and keep just the good parts - - - - - f7a22268 by Rodrigo Mesquita at 2026-09-04T17:38:20+01:00 just to test rtti of final_ids if that would work - - - - - 9 changed files: - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/Runtime/Heap/Inspect.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - libraries/ghci/GHCi/Run.hs - + libraries/ghci/GHCi/Run/Breakpoints.hs - libraries/ghci/ghci.cabal.in Changes: ===================================== compiler/GHC/Runtime/Debugger.hs ===================================== @@ -121,8 +121,7 @@ pprintClosureCommand bindThings force str = do -- Then, we extract a substitution, -- mapping the old tyvars to the reconstructed types. let reconstructed_type = termType term - hsc_env <- getSession - case (improveRTTIType hsc_env id_ty' reconstructed_type) of + case improveRTTIType id_ty' reconstructed_type of Nothing -> return (subst, term') Just subst' -> do { logger <- getLogger ; liftIO $ ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -131,7 +131,7 @@ import GHC.ByteCode.Breakpoints import Control.Monad import Data.Dynamic import Data.IntMap (IntMap) -import Data.List (find,intercalate) +import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) import Unsafe.Coerce ( unsafeCoerce ) import qualified GHC.Unit.Home.Graph as HUG @@ -244,12 +244,12 @@ execStmt' stmt stmt_text ExecOptions{..} = do handleRunStatus execSingleStep execIsolateMode stmt_text bindings ids status (emptyHistory size) -runDecls :: GhcMonad m => String -> m [Name] +runDecls :: GhcMonad m => String -> m [TyThing] runDecls = runDeclsWithLocation "<interactive>" 1 -- | Run some declarations and return any user-visible names that were brought -- into scope. -runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] +runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [TyThing] runDeclsWithLocation source line_num input = do hsc_env <- getSession decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input) @@ -258,18 +258,17 @@ runDeclsWithLocation source line_num input = do -- | Like `runDeclsWithLocation`, but takes parsed declarations as argument. -- Useful when doing preprocessing on the AST before execution, e.g. in GHCi -- (see GHCi.UI.runStmt). -runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name] +runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [TyThing] runParsedDecls decls = do - hsc_env <- getSession - (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls) - + hsc_env <- getSession + (tyThings, ic) <- liftIO $ hscParsedDecls hsc_env decls setSession $ hsc_env { hsc_IC = ic } hsc_env <- getSession hsc_env' <- liftIO $ rttiEnvironment hsc_env setSession hsc_env' - return $ filter (not . isDerivedOccName . nameOccName) + return $ filter (not . isDerivedOccName . nameOccName . getName) -- For this filter, see Note [What to show to users] - $ map getName tyThings + $ tyThings {- Note [What to show to users] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -316,7 +315,8 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do liftIO $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip final_names hvals) hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} setSession hsc_env' - return (ExecComplete (Right final_names) allocs) + let improved_final_ids = filter (`elem` final_ids) [ i | AnId i <- ic_tythings $ hsc_IC hsc_env' ] -- just to test + return (ExecComplete (Right improved_final_ids {- TODO: THESE MUST BE IMPROVED BEFORE RETURNED -}) allocs) -- Completed with an exception EvalComplete alloc (EvalException e) -> @@ -327,7 +327,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref let span = mkGeneralSrcSpan (fsLit "<unknown>") - (hsc_env1, names) <- liftIO $ + (hsc_env1, break_ids) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack_fhv span Nothing let resume = Resume @@ -346,7 +346,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do hsc_env2 = pushResume hsc_env1 resume setSession hsc_env2 - return (ExecBreak names Nothing) + return (ExecBreak break_ids Nothing resume) -- EvalBreak (Just ...) case: the interpreter stopped at a breakpoint -- @@ -374,7 +374,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do -- This function only returns control to ghci with 'ExecBreak' when it is really meant to break. -- Specifically, for :steplocal or :stepmodule, don't return control -- and simply resume execution from here until we hit a breakpoint we do want to stop at. - (hsc_env1, names) <- liftIO $ + (hsc_env1, final_ids) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) let resume = Resume @@ -392,7 +392,7 @@ handleRunStatus step isolateMode expr bindings final_ids status history0 = do } hsc_env2 = pushResume hsc_env1 resume setSession hsc_env2 - return (ExecBreak names (Just ibi)) + return (ExecBreak final_ids (Just ibi) resume) else do -- resume with the same step type let eval_opts = (initEvalOpts dflags (enableGhcStepMode step)) @@ -500,13 +500,13 @@ getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do ( ld_st' , ba ) -back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) +back :: GhcMonad m => Int -> m ([Id], Int, SrcSpan) back n = moveHist (+n) -forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) +forward :: GhcMonad m => Int -> m ([Id], Int, SrcSpan) forward n = moveHist (subtract n) -moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan) +moveHist :: GhcMonad m => (Int -> Int) -> m ([Id], Int, SrcSpan) moveHist fn = do hsc_env <- getSession case ic_resume (hsc_IC hsc_env) of @@ -530,7 +530,7 @@ moveHist fn = do let hug = hsc_HUG hsc_env brks <- readIModBreaks hug ibi getBreakLoc (readIModModBreaks hug) ibi brks - (hsc_env1, names) <- + (hsc_env1, final_ids) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info let ic = hsc_IC hsc_env1 r' = r { resumeHistoryIx = new_ix } @@ -538,7 +538,7 @@ moveHist fn = do setSession hsc_env1{ hsc_IC = ic' } - return (names, new_ix, span) + return (final_ids, new_ix, span) -- careful: we want apStack to be the AP_STACK itself, not a thunk -- around it, hence the cases are carefully constructed below to @@ -564,7 +564,7 @@ bindLocalsAtBreakpoint -> ForeignHValue -> SrcSpan -> Maybe InternalBreakpointId - -> IO (HscEnv, [Name]) + -> IO (HscEnv, [Id]) -- Nothing case: we stopped when an exception was raised, not at a -- breakpoint. We have no location information or local variables to @@ -584,7 +584,7 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do interp = hscInterp hsc_env -- Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(exn_name, apStack)] - return (hsc_env{ hsc_IC = ictxt1 }, [exn_name]) + return (hsc_env{ hsc_IC = ictxt1 }, [exn_id]) -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. @@ -645,7 +645,8 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip names fhvs) when result_ok $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(result_name, apStack_fhv)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, if result_ok then result_name:names else names) + let improved_final_ids = filter (`elem` final_ids) [ i | AnId i <- ic_tythings $ hsc_IC hsc_env1 ] -- just to test + return (hsc_env1, improved_final_ids {-TODO: IMPROVE RTTI -}) where -- We need a fresh Unique for each Id we bind, because the linker -- state is single-threaded and otherwise we'd spam old bindings @@ -692,12 +693,10 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do [id | id <- tmp_ids , not $ noSkolems id , (occNameFS.nameOccName.idName) id /= result_fs] - foldM improveTypes hsc_env (map idName incompletelyTypedIds) + foldM improveTypes hsc_env incompletelyTypedIds where noSkolems = noFreeVarsOfType . idType - improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do - let tmp_ids = [id | AnId id <- ic_tythings ic] - id = expectJust $ find (\i -> idName i == name) tmp_ids + improveTypes hsc_env@HscEnv{hsc_IC=ic} id = do if noSkolems id then return hsc_env else do @@ -706,7 +705,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do case mb_new_ty of Nothing -> return hsc_env Just new_ty -> do - case improveRTTIType hsc_env old_ty new_ty of + case improveRTTIType old_ty new_ty of Nothing -> warnPprTrace True (":print failed to calculate the " ++ "improvement for a type") (vcat [ text "id" <+> ppr id ===================================== compiler/GHC/Runtime/Eval/Types.hs ===================================== @@ -21,7 +21,6 @@ import GHCi.Message (EvalExpr) import GHC.ByteCode.Types (InternalBreakpointId(..)) import GHC.Driver.Config (EvalStep(..)) import GHC.Types.Id -import GHC.Types.Name import GHC.Types.TyThing import GHC.Types.Name.Reader import GHC.Types.SrcLoc @@ -160,7 +159,7 @@ data ExecResult -- | Execution is complete with either an exception or the list of -- user-visible names that were brought into scope. = ExecComplete - { execResult :: Either SomeException [Name] + { execResult :: Either SomeException [Id] , execAllocation :: Word64 } @@ -171,8 +170,10 @@ data ExecResult -- subsequently deciding whether to really stop here. -- `ExecBreak` always means GHCi breaks. | ExecBreak - { breakNames :: [Name] + { breakNames :: [Id] , breakPointId :: Maybe InternalBreakpointId + , breakResume :: Resume + -- ^ to resume this thread blocked on this break } -- | Essentially a GlobalRdrEnv, but with additional cached values to allow ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -1160,8 +1160,8 @@ findPtrTyss i tys = foldM step (i, []) tys -- improveType <base_type> <rtti_type> -- The types can contain skolem type variables, which need to be treated as normal vars. -- In particular, we want them to unify with things. -improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe Subst -improveRTTIType _ base_ty new_ty = U.tcUnifyDebugger base_ty new_ty +improveRTTIType :: RttiType -> RttiType -> Maybe Subst +improveRTTIType base_ty new_ty = U.tcUnifyDebugger base_ty new_ty getDataConArgTys :: DataCon -> Type -> TR [Type] -- Given the result type ty of a constructor application (D a b c :: ty) ===================================== ghc/GHCi/UI.hs ===================================== @@ -1473,7 +1473,7 @@ runOneCommand eh gCmd = do -- runStmt wrapper for temporarily overridden line-number runStmtWithLineNum :: Int -> String -> SingleStep - -> GHCi (Maybe GHC.ExecResult) + -> GHCi (Maybe RunResult) runStmtWithLineNum lnum stmt step = do st0 <- getGHCiState setGHCiState st0 { line_number = lnum } @@ -1538,7 +1538,7 @@ enqueueCommands cmds = do -- | Entry point to execute some haskell code from user. -- The return value True indicates success, as in `runOneCommand`. -runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult) +runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe RunResult) runStmt input step = do dflags <- GHC.getInteractiveDynFlags let pflags = initParserOpts dflags @@ -1560,7 +1560,7 @@ runStmt input step = do case mb_stmt of Nothing -> -- empty statement / comment - return (Just exec_complete) + return (Just (RunDeclsResult [])) Just stmt -> run_stmt stmt @@ -1583,8 +1583,6 @@ runStmt input step = do run_imports imports run_decls decls where - exec_complete = GHC.ExecComplete (Right []) 0 - run_imports imports = mapM_ (addImportToContext . unLoc) imports set_pragmas pflags sec supported = @@ -1593,12 +1591,12 @@ runStmt input step = do opts = unLoc <$> loc_opts in setOptions opts - run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult) + run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe RunResult) run_stmt stmt = do m_result <- GhciMonad.runStmt stmt input step case m_result of Nothing -> return Nothing - Just result -> Just <$> afterRunStmt step result + Just result -> Just <$> afterRunStmt (RunStmtResult result) -- `x = y` (a declaration) should be treated as `let x = y` (a statement). -- The reason is because GHCi wasn't designed to support `x = y`, but then @@ -1614,7 +1612,7 @@ runStmt input step = do -- -- Instead of dealing with all these problems individually here we fix this -- mess by just treating `x = y` as `let x = y`. - run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult) + run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe RunResult) -- Only turn `FunBind` and `VarBind` into statements, other bindings -- (e.g. `PatBind`) need to stay as decls. run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt (locA l) bind) @@ -1629,8 +1627,8 @@ runStmt input step = do -- a file, otherwise the read buffer can't be flushed). _ <- liftIO $ tryIO $ hFlushAll stdin m_result <- GhciMonad.runDecls' decls - forM m_result $ \result -> - afterRunStmt step (GHC.ExecComplete (Right result) 0) + forM m_result $ \result -> do + afterRunStmt (RunDeclsResult result) mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs mk_stmt loc bind = @@ -1646,32 +1644,33 @@ runStmt input step = do where modStr = moduleNameString $ moduleName $ icInteractiveModule $ ic +data RunResult + = RunStmtResult GHC.ExecResult + | RunDeclsResult [TyThing] + -- | Clean up the GHCi environment after a statement has run -afterRunStmt :: GhciMonad m => SingleStep {-^ Type of step we took just before -} - -> GHC.ExecResult -> m GHC.ExecResult -afterRunStmt step run_result = do - resumes <- GHC.getResumeContext +afterRunStmt :: GhciMonad m + => RunResult -> m RunResult +afterRunStmt run_result = do case run_result of - GHC.ExecComplete{..} -> - case execResult of - Left ex -> liftIO $ Exception.throwIO ex - Right names -> do - show_types <- isOptionSet ShowType - when show_types $ printTypeOfNames names - GHC.ExecBreak names mb_info - | first_resume : _ <- resumes - -> do mb_id_loc <- toBreakIdAndLocation mb_info - let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc - if (null bCmd) - then printStoppedAtBreakInfo first_resume names - else enqueueCommands [bCmd] - -- run the command set with ":set stop <cmd>" - st <- getGHCiState - enqueueCommands [stop st] - return () - - | otherwise -> resume step Nothing >>= - afterRunStmt step >> return () + RunDeclsResult things -> do + show_types <- isOptionSet ShowType + when show_types $ printTypeOfThings things + RunStmtResult GHC.ExecComplete{..} -> + case execResult of + Left ex -> liftIO $ Exception.throwIO ex + Right ids -> do + show_types <- isOptionSet ShowType + when show_types $ printTypeOfIds ids + RunStmtResult (GHC.ExecBreak ids mb_info resume) -> do + mb_id_loc <- toBreakIdAndLocation mb_info + let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc + if (null bCmd) + then printStoppedAtBreakInfo resume ids + else enqueueCommands [bCmd] + -- run the command set with ":set stop <cmd>" + st <- getGHCiState + enqueueCommands [stop st] flushInterpBuffers withSignalHandlers $ do @@ -1680,16 +1679,18 @@ afterRunStmt step run_result = do return run_result -runSuccess :: Maybe GHC.ExecResult -> Bool +runSuccess :: Maybe RunResult -> Bool runSuccess run_result - | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True + | Just (RunDeclsResult _) <- run_result = True + | Just (RunStmtResult GHC.ExecComplete { execResult = Right _ }) + <- run_result = True | otherwise = False -runAllocs :: Maybe GHC.ExecResult -> Maybe Integer +runAllocs :: Maybe RunResult -> Maybe Integer runAllocs m = do res <- m case res of - GHC.ExecComplete{..} -> Just (fromIntegral execAllocation) + RunStmtResult GHC.ExecComplete{..} -> Just (fromIntegral execAllocation) _ -> Nothing toBreakIdAndLocation :: GhciMonad m @@ -1703,30 +1704,23 @@ toBreakIdAndLocation (Just inf) = do return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st), breakId loc == bi ] -printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m () -printStoppedAtBreakInfo res names = do +printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [GHC.Id] -> m () +printStoppedAtBreakInfo res ids = do printForUser =<< pprStopped res - -- printTypeOfNames session names - let namesSorted = sortBy compareNames names - tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted - docs <- mapM pprTypeAndContents [i | AnId i <- tythings] + let idsSorted = sortBy (compareNames `on` getName) ids + docs <- mapM pprTypeAndContents idsSorted printForUserPartWay $ vcat docs -printTypeOfNames :: GHC.GhcMonad m => [Name] -> m () -printTypeOfNames names - = mapM_ (printTypeOfName ) $ sortBy compareNames names +printTypeOfIds :: GHC.GhcMonad m => [GHC.Id] -> m () +printTypeOfIds = printTypeOfThings . map AnId + +printTypeOfThings :: GHC.GhcMonad m => [GHC.TyThing] -> m () +printTypeOfThings things + = mapM_ printTyThing $ sortBy (compareNames `on` getName) things compareNames :: Name -> Name -> Ordering compareNames = on compare getOccString S.<> on SrcLoc.leftmost_smallest getSrcSpan -printTypeOfName :: GHC.GhcMonad m => Name -> m () -printTypeOfName n - = do maybe_tything <- GHC.lookupName n - case maybe_tything of - Nothing -> return () - Just thing -> printTyThing thing - - data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand -- | Entry point for execution a ':<command>' input from user @@ -4375,7 +4369,7 @@ doContinue step = doContinue' step Nothing doContinue' :: GhciMonad m => SingleStep -> Maybe Int -> m () doContinue' step mbCnt= do runResult <- resume step mbCnt - _ <- afterRunStmt step runResult + _ <- afterRunStmt (RunStmtResult runResult) return () abandonCmd :: GhciMonad m => String -> m () @@ -4526,9 +4520,9 @@ backCmd arg | otherwise = liftIO $ putStrLn "Syntax: :back [num]" where back num = withSandboxOnly ":back" $ do - (names, _, pan) <- GHC.back num + (ids, _, pan) <- GHC.back num printForUser $ text "Logged breakpoint at" <+> ppr pan - printTypeOfNames names + printTypeOfIds ids -- run the command set with ":set stop <cmd>" st <- getGHCiState enqueueCommands [stop st] @@ -4540,11 +4534,11 @@ forwardCmd arg | otherwise = liftIO $ putStrLn "Syntax: :forward [num]" where forward num = withSandboxOnly ":forward" $ do - (names, ix, pan) <- GHC.forward num + (ids, ix, pan) <- GHC.forward num printForUser $ (if (ix == 0) then text "Stopped at" else text "Logged breakpoint at") <+> ppr pan - printTypeOfNames names + printTypeOfIds ids -- run the command set with ":set stop <cmd>" st <- getGHCiState enqueueCommands [stop st] ===================================== ghc/GHCi/UI/Monad.hs ===================================== @@ -381,7 +381,7 @@ runStmt stmt stmt_text step = do (EvalThis fhv) } Just <$> GHC.execStmt' stmt stmt_text opts -runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name]) +runDecls :: GhciMonad m => String -> m (Maybe [GHC.TyThing]) runDecls decls = do st <- getGHCiState reifyGHCi $ \x -> @@ -393,7 +393,7 @@ runDecls decls = do r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls return (Just r) -runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name]) +runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.TyThing]) runDecls' decls = do st <- getGHCiState reifyGHCi $ \x -> ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -1,7 +1,6 @@ {-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP, - UnboxedTuples, LambdaCase, UnliftedFFITypes, NamedFieldPuns #-} + UnboxedTuples, LambdaCase, UnliftedFFITypes, NamedFieldPuns, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# LANGUAGE BangPatterns #-} -- | -- Execute GHCi messages. @@ -20,6 +19,7 @@ import GHCi.CreateBCO import GHCi.InfoTable #endif +import GHCi.Run.Breakpoints import GHCi.Coverage import qualified GHC.InfoProv as InfoProv import GHCi.Debugger @@ -31,8 +31,6 @@ import GHCi.TH import GHCi.BreakArray import GHCi.StaticPtrTable -import qualified Data.Map as Map -import qualified Data.Set as Set import Control.Concurrent import Control.DeepSeq import Control.Exception @@ -290,7 +288,7 @@ abandonStmt hvref = do tid <- localRef hvref ResumeContext{..} <- getThreadResumeContext tid killThread tid - withShadowThread tid $ do + withIsolatedThread tid $ do putMVar resumeBreakMVar () _ <- atomically $ readThreadEvalStatus tid @@ -424,13 +422,13 @@ withBreakAction opts tid@(ThreadId tid#) act runIf# singleStep rts_enableStopNextBreakpoint runIf# stepOut rts_enableStopAfterReturn - runIf isolateThreadBreaks setShadowThread + runIf isolateThreadBreaks setIsolatedThread resetBreakAction () = do poke exceptionFlag 0 rts_disableStopAfterReturn tid# rts_disableStopNextBreakpoint tid# - runIf isolateThreadBreaks unsetShadowThread + runIf isolateThreadBreaks unsetIsolatedThread -- freeStablePtr stablePtr TODO: we never free the global stablePtr for -- global action. Maybe we should have a de-init for clean up. @@ -484,186 +482,3 @@ clearEvalStatus = \case EvalComplete w (EvalSuccess _) -> EvalComplete w (EvalSuccess ()) EvalBreak ap mb rt rccs -> EvalBreak ap mb rt rccs --------------------------------------------------------------------------------- --- Global Debugger Per-Thread Context --- TODO: when to clean MVar? how to figure out when Threads are dead and we'll never need their mvars again? perhaps a finalizer on the thread id? --- TODO: Move to independent module, and don't expose the global variables at all. move also the global break action maybe. --- Maybe there could even be something in that module for setting the global --- break action on start. maybe just an init function --- --- TODO: Note which explains when things are evacuated from the map, why --- EvalSuccess's don't leak, what is the idea, why have MVar and TVar, why have --- shadowed threads. Must also explain whatever we come up with for Finalizers --- to make sure threads evacuate themselves out of the map. Explain in the note --- as well the status of GHCi multi-threaded, explaining it currently uses --- single-threaded --- --- TODO: Write a blog post about multi-threaded debugging (mby with the contents of the note..) - -globalBreakStablePtr :: StablePtr BreakpointCallback -globalBreakStablePtr = unsafePerformIO $ newStablePtr globalBreakAction - -globalBreakAction :: BreakpointCallback -globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do - tid <- myThreadId - ResumeContext{..} <- getThreadResumeContext tid - resume_r <- mkRemoteRef tid - apStack_r <- mkRemoteRef apStack - ccs <- toRemotePtr <$> getCCSOf apStack - breakpoint <- - if is_exception - then pure Nothing - else do - info_mod <- BS.packCString (Ptr info_mod#) - info_mod_uid <- BS.packCString (Ptr info_mod_uid#) - pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#))) - writeThreadEvalStatus tid $ EvalBreak apStack_r breakpoint resume_r ccs - - -- Block until this thread is resumed (by the thread which took the - -- `ResumeContext` from the `statusMVar`). - -- - -- The `onBreak` function must have been called from `rts/Interpreter.c` - -- when interpreting a `BRK_FUN`. After taking from the MVar, the function - -- returns to the continuation on the stack which is where the interpreter - -- was stopped. - takeMVar resumeBreakMVar - -getThreadResumeContext :: ThreadId -> IO ResumeContext -getThreadResumeContext tid = modifyMVar globalBreakActionMap $ \gbm0 -> do - case Map.lookup tid gbm0 of - Nothing -> do - r <- ResumeContext <$> newEmptyMVar - let !gbm1 = Map.insert tid r gbm0 - pure (gbm1, r) - Just ctx -> do - pure (gbm0, ctx) - --- | A global mapping from thread ids to the MVars on which they block when stopped. -globalBreakActionMap :: MVar (Map.Map ThreadId ResumeContext) -globalBreakActionMap = unsafePerformIO $ newMVar Map.empty -{-# NOINLINE globalBreakActionMap #-} - -newtype ResumeContext = ResumeContext - { resumeBreakMVar :: MVar () - -- ^ A thread that hits a breakpoint blocks reading its corresponding MVar - -- (gotten from the 'globalBreakActionMap'). - -- The debugger can unblock that thread by signaling its MVar. - } - --- | To evaluate a statement in the interpreter, a thread is forked by --- `sandboxIO` to run the statement. To synchronize, the statement result will --- be written by the thread to the global thread dbg status --- (`writeThreadEvalStatus`) and `sandboxIO` will block waiting for either any --- breakpoint to be hit ('readAnyThreadEvalBreak') /or/ for the thread --- specifically to write its final result. To wait for that thread --- specifically, use this function. --- --- Succeeds when the given thread writes to the global debugger map an eval result. -readThreadEvalStatus :: ThreadId -> STM (EvalStatus [HValueRef]) -readThreadEvalStatus tid = do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - case Map.lookup tid threadEvalStatuses of - Just r -> do - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses = Map.delete tid threadEvalStatuses -- clear it - , shadowedThreads - } - pure r - Nothing -> retry -- until someone writes the result for this thread - --- | All threads running in the interpreter will be debugger-enabled, meaning --- if they hit an enabled breakpoint, the 'globalBreakAction' will be --- executed and write a 'EvalBreak' value to the global thread dbg status map. --- The debugger will be waiting for threads to break using `readAnyThreadEvalBreak`. --- --- Succeeds when any thread hits a breakpoint. -readAnyThreadEvalBreak :: STM EvalBreak -readAnyThreadEvalBreak = do - dbgs <- readTVar globalDbgStatusVar - -- try reading any thread's 'EvalBreak' and retry if none have yielded one yet - foldr (\x next -> readStatus dbgs x `orElse` next) retry (Map.toList (threadEvalStatuses dbgs)) - where - readStatus GlobalDbgStatus{..} (tid, _) -- don't look at dbg-shadowed threads - | Set.member tid shadowedThreads - = retry - - readStatus GlobalDbgStatus{..} (tid, status) - = do - case status of - EvalComplete{} -> retry -- successes can be read with `readThreadEvalStatus` - EvalPaused b -> do - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses = Map.delete tid threadEvalStatuses - , shadowedThreads - } - pure b - -writeThreadEvalStatus :: ThreadId -> EvalStatus [HValueRef] -> IO () -writeThreadEvalStatus tid new = - atomically $ do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - writeTVar globalDbgStatusVar $ - GlobalDbgStatus - { threadEvalStatuses = - Map.insertWith (\_ _ -> error "writeThreadEvalStatus: should be impossible") - tid new threadEvalStatuses - , shadowedThreads } - --- | Brackets 'setShadowThread' -withShadowThread :: ThreadId -> IO a -> IO a -withShadowThread tid = bracket_ (setShadowThread tid) (unsetShadowThread tid) - --- | Make sure that anyone watching for threads hitting breakpoints with --- 'readAnyThreadEvalBreak' ignore the given thread if it ever hits a breakpoint. --- --- This forces this thread's result to be received solely through --- 'readThreadEvalStatus' for that ThreadId, which is typically desired when an --- expression to run should not be seen at all by the debugger (e.g. when --- evaluating an expr to :force a variable) -setShadowThread :: ThreadId -> IO () -setShadowThread tid = atomically $ do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses - , shadowedThreads = Set.insert tid shadowedThreads - } - --- | Undoes 'setShadowThread' -unsetShadowThread :: ThreadId -> IO () -unsetShadowThread tid = atomically $ do - GlobalDbgStatus{..} <- readTVar globalDbgStatusVar - writeTVar globalDbgStatusVar - GlobalDbgStatus - { threadEvalStatuses - , shadowedThreads = Set.delete tid shadowedThreads - } - --- | When we launch a new thread using the debugger, we map ... TODO ... all --- threads launched by that main stmt may further spawn threads, and any of --- them might hit a breakpoint (break array toggled, or per-thread step in --- might be used, or pause button, etc...). --- --- When we launch that main thread we also write its result to this map. So --- this map will only contain the results of threads we explicitly care to --- observe the result of. Not all threads will write their results here, --- certainly not ones spawned unknowningly by the main stmt. --- ... --- todo words -globalDbgStatusVar :: TVar GlobalDbgStatus -globalDbgStatusVar = unsafePerformIO $ newTVarIO $ GlobalDbgStatus Map.empty Set.empty -{-# NOINLINE globalDbgStatusVar #-} - -data GlobalDbgStatus = GlobalDbgStatus - { threadEvalStatuses :: !(Map.Map ThreadId (EvalStatus [HValueRef])) - -- ^ Whenever a thread hits a breakpoint it inserts in this map its 'EvalBreak'. - -- We can additionally observe a thread's result by calling - -- `writeThreadEvalStatus tid (EvalComplete ...)` when the main expression - -- finishes evaluating, see e.g. 'sandboxIO'. - , shadowedThreads :: !(Set.Set ThreadId) - -- ^ Threads in this map are meant to be ignored by 'readAnyThreadEvalBreak'. - -- That is, even if one of the threads in this set hits a breakpoint, we - -- can only read its 'EvalBreak' with @'readThreadEvalStatus' tid@ directly. - } ===================================== libraries/ghci/GHCi/Run/Breakpoints.hs ===================================== @@ -0,0 +1,264 @@ +{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP, + UnboxedTuples, LambdaCase, UnliftedFFITypes, NamedFieldPuns, BangPatterns #-} +module GHCi.Run.Breakpoints + ( + -- * Global break action + globalBreakStablePtr, globalBreakAction + + -- * Per-thread breakpoints + , readThreadEvalStatus, readAnyThreadEvalBreak + , writeThreadEvalStatus + + -- ** Isolating thread breakpoints + , withIsolatedThread + , setIsolatedThread, unsetIsolatedThread + + -- ** Querying the global thread breakpoint map + , listOtherPausedThreads + + -- * Per-thread resume-ing + , getThreadResumeContext, ResumeContext(..) + + ) + where + +import Prelude -- See note [Why do we import Prelude here?] + +import GHCi.Debugger +import GHCi.Message +import GHCi.RemoteTypes + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Concurrent +import Control.Exception +import qualified Data.ByteString.Short.Internal as BS +#if defined(PROFILING) +import GHC.Data.ShortByteString +#endif +import GHC.Exts +import GHC.Stack +import Foreign hiding (void) +import GHC.Conc.Sync +import GHC.IO hiding ( bracket ) + +-------------------------------------------------------------------------------- +-- * Global break action +-------------------------------------------------------------------------------- +-- Global Debugger Per-Thread Context +-- TODO: when to clean MVar? how to figure out when Threads are dead and we'll +-- never need their mvars again? perhaps a finalizer on the thread id? +-- +-- TODO: Move to independent module, and don't expose the global variables at all. move also the global break action maybe. +-- Maybe there could even be something in that module for setting the global +-- break action on start. maybe just an init function +-- +-- TODO: Note which explains when things are evacuated from the map, why +-- EvalSuccess's don't leak, what is the idea, why have MVar and TVar, why have +-- isolated threads. Must also explain whatever we come up with for Finalizers +-- to make sure threads evacuate themselves out of the map. Explain in the note +-- as well the status of GHCi multi-threaded, explaining it currently uses +-- single-threaded +-- +-- TODO: Write a blog post about multi-threaded debugging (mby with the contents of the note..) + +-- TODO: Maybe this could be the return value of doing initialization for the +-- debugger, which allocates this stable pointer and sets it in the global action. +-- +-- And de-initialization deallocates this stable pointer and then some other things +globalBreakStablePtr :: StablePtr BreakpointCallback +globalBreakStablePtr = unsafePerformIO $ newStablePtr globalBreakAction + +globalBreakAction :: BreakpointCallback +globalBreakAction info_mod# info_mod_uid# infox# is_exception apStack = do + tid <- myThreadId + ResumeContext{..} <- getThreadResumeContext tid + resume_r <- mkRemoteRef tid + apStack_r <- mkRemoteRef apStack + ccs <- toRemotePtr <$> getCCSOf apStack + mb_breakpoint <- + if is_exception + then pure Nothing + else do + info_mod <- BS.packCString (Ptr info_mod#) + info_mod_uid <- BS.packCString (Ptr info_mod_uid#) + pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#))) + writeThreadEvalStatus tid $ EvalBreak apStack_r mb_breakpoint resume_r ccs + + -- Block until this thread is resumed (by the thread which took the + -- `ResumeContext` from the `statusMVar`). + -- + -- The `onBreak` function must have been called from `rts/Interpreter.c` + -- when interpreting a `BRK_FUN`. After taking from the MVar, the function + -- returns to the continuation on the stack which is where the interpreter + -- was stopped. + takeMVar resumeBreakMVar + +-------------------------------------------------------------------------------- +-- * Per-thread breakpoints +-------------------------------------------------------------------------------- + +-- | To evaluate a statement in the interpreter, a thread is forked by +-- `sandboxIO` to run the statement. To synchronize, the statement result will +-- be written by the thread to the global thread dbg status +-- (`writeThreadEvalStatus`) and `sandboxIO` will block waiting for either any +-- breakpoint to be hit ('readAnyThreadEvalBreak') /or/ for the thread +-- specifically to write its final result. To wait for that thread +-- specifically, use this function. +-- +-- Succeeds when the given thread writes to the global debugger map an eval result. +readThreadEvalStatus :: ThreadId -> STM (EvalStatus [HValueRef]) +readThreadEvalStatus tid = do + GlobalDbgStatus{..} <- readTVar globalDbgStatusVar + case Map.lookup tid threadEvalStatuses of + Just r -> do + writeTVar globalDbgStatusVar + GlobalDbgStatus + { threadEvalStatuses = Map.delete tid threadEvalStatuses -- clear it + , isolatedThreads + } + pure r + Nothing -> retry -- until someone writes the result for this thread + +-- | All threads running in the interpreter will be debugger-enabled, meaning +-- if they hit an enabled breakpoint, the 'globalBreakAction' will be +-- executed and write a 'EvalBreak' value to the global thread dbg status map. +-- The debugger will be waiting for threads to break using `readAnyThreadEvalBreak`. +-- +-- Succeeds when any thread hits a breakpoint. +readAnyThreadEvalBreak :: STM EvalBreak +readAnyThreadEvalBreak = do + dbgs <- readTVar globalDbgStatusVar + -- try reading any thread's 'EvalBreak' and retry if none have yielded one yet + foldr (\x next -> readStatus dbgs x `orElse` next) retry (Map.toList (threadEvalStatuses dbgs)) + where + readStatus GlobalDbgStatus{..} (tid, _) -- don't look at isolated threads + | Set.member tid isolatedThreads + = retry + + readStatus GlobalDbgStatus{..} (tid, status) + = do + case status of + EvalComplete{} -> retry -- successes can be read with `readThreadEvalStatus` + EvalPaused b -> do + writeTVar globalDbgStatusVar + GlobalDbgStatus + { threadEvalStatuses = Map.delete tid threadEvalStatuses + , isolatedThreads + } + pure b + +writeThreadEvalStatus :: ThreadId -> EvalStatus [HValueRef] -> IO () +writeThreadEvalStatus tid status = + atomically $ do + GlobalDbgStatus{..} <- readTVar globalDbgStatusVar + writeTVar globalDbgStatusVar $ + GlobalDbgStatus + { threadEvalStatuses = + Map.insertWith (\_ _ -> error "writeThreadEvalStatus: should be impossible") + tid status threadEvalStatuses + , isolatedThreads } + + +-- ** Isolating thread breakpoints --------------------------------------------- + +-- | Brackets 'setIsolatedThread' +withIsolatedThread :: ThreadId -> IO a -> IO a +withIsolatedThread tid = bracket_ (setIsolatedThread tid) (unsetIsolatedThread tid) + +-- | Make sure that anyone watching for threads hitting breakpoints with +-- 'readAnyThreadEvalBreak' ignore the given thread if it ever hits a breakpoint. +-- +-- This forces this thread's result to be received solely through +-- 'readThreadEvalStatus' for that ThreadId, which is typically desired when an +-- expression to run should not be seen at all by the debugger (e.g. when +-- evaluating an expr to :force a variable) +setIsolatedThread :: ThreadId -> IO () +setIsolatedThread tid = atomically $ do + GlobalDbgStatus{..} <- readTVar globalDbgStatusVar + writeTVar globalDbgStatusVar + GlobalDbgStatus + { threadEvalStatuses + , isolatedThreads = Set.insert tid isolatedThreads + } + +-- | Undoes 'setIsolatedThread' +unsetIsolatedThread :: ThreadId -> IO () +unsetIsolatedThread tid = atomically $ do + GlobalDbgStatus{..} <- readTVar globalDbgStatusVar + writeTVar globalDbgStatusVar + GlobalDbgStatus + { threadEvalStatuses + , isolatedThreads = Set.delete tid isolatedThreads + } + +-- ** Querying the global thread breakpoint map -------------------------------- + +-- | List all other threads paused on a breakpoint. +-- +-- We say "other" because this function is meant to be used in the scenario +-- where you are already paused at a breakpoint (which has been popped off of +-- the global thread mapping) and are asking about which other threads are +-- paused to list them. +listOtherPausedThreads :: IO [ThreadId] +listOtherPausedThreads = do + m <- atomically $ readTVar globalDbgStatusVar + pure $ Map.keys $ Map.filter isBreak (threadEvalStatuses m) + where + isBreak EvalBreak{} = True + isBreak EvalComplete{} = False + +-- ** Global thread exec status map -------------------------------------------- + +-- | When we launch a new thread using the debugger, we map ... TODO ... all +-- threads launched by that main stmt may further spawn threads, and any of +-- them might hit a breakpoint (break array toggled, or per-thread step in +-- might be used, or pause button, etc...). +-- +-- When we launch that main thread we also write its result to this map. So +-- this map will only contain the results of threads we explicitly care to +-- observe the result of. Not all threads will write their results here, +-- certainly not ones spawned unknowningly by the main stmt. +-- ... +-- todo words +globalDbgStatusVar :: TVar GlobalDbgStatus +globalDbgStatusVar = unsafePerformIO $ newTVarIO $ GlobalDbgStatus Map.empty Set.empty +{-# NOINLINE globalDbgStatusVar #-} + +data GlobalDbgStatus = GlobalDbgStatus + { threadEvalStatuses :: !(Map.Map ThreadId (EvalStatus [HValueRef])) + -- ^ Whenever a thread hits a breakpoint it inserts in this map its 'EvalBreak'. + -- We can additionally observe a thread's result by calling + -- `writeThreadEvalStatus tid (EvalComplete ...)` when the main expression + -- finishes evaluating, see e.g. 'sandboxIO'. + , isolatedThreads :: !(Set.Set ThreadId) + -- ^ Threads in this map are meant to be ignored by 'readAnyThreadEvalBreak'. + -- That is, even if one of the threads in this set hits a breakpoint, we + -- can only read its 'EvalBreak' with @'readThreadEvalStatus' tid@ directly. + } + +-------------------------------------------------------------------------------- +-- * Per-thread resume-ing +-------------------------------------------------------------------------------- + +getThreadResumeContext :: ThreadId -> IO ResumeContext +getThreadResumeContext tid = modifyMVar globalBreakActionMap $ \gbm0 -> do + case Map.lookup tid gbm0 of + Nothing -> do + r <- ResumeContext <$> newEmptyMVar + let !gbm1 = Map.insert tid r gbm0 + pure (gbm1, r) + Just ctx -> do + pure (gbm0, ctx) + +-- | A global mapping from thread ids to the MVars on which they block when stopped. +globalBreakActionMap :: MVar (Map.Map ThreadId ResumeContext) +globalBreakActionMap = unsafePerformIO $ newMVar Map.empty +{-# NOINLINE globalBreakActionMap #-} + +newtype ResumeContext = ResumeContext + { resumeBreakMVar :: MVar () + -- ^ A thread that hits a breakpoint blocks reading its corresponding MVar + -- (gotten from the 'globalBreakActionMap'). + -- The debugger can unblock that thread by signaling its MVar. + } ===================================== libraries/ghci/ghci.cabal.in ===================================== @@ -61,6 +61,7 @@ library exposed-modules: GHCi.Coverage GHCi.Run + GHCi.Run.Breakpoints GHCi.Debugger GHCi.CreateBCO GHCi.ObjLink View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d82db8234bbbbe11096988b3210d8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d82db8234bbbbe11096988b3210d8… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/T27731] Simplify the error-suppression mechanism in GHC.Tc.Errors
by Simon Peyton Jones (＠simonpj) 05 Sep '26

05 Sep '26

Simon Peyton Jones pushed to branch wip/T27731 at Glasgow Haskell Compiler / GHC Commits: 46482c15 by Simon Peyton Jones at 2026-09-04T17:03:07+01:00 Simplify the error-suppression mechanism in GHC.Tc.Errors In GHC.Tc.Errors.reportWanteds we suppress some errors in favour of others. But the mechanism had grown crufty, and #27331 exposed a bug. This MR makes it simpler and more uniform, by doing everything via the `ei_suppress` field of the ErrorItem. Claude then found another closely-related bug (see the review linked on !16564). That bug is immortalised in new test T18851d. I'm still not happy with `ignoreConstraint` but we can worry about that another day; I have not touched it. - - - - - 10 changed files: - + changelog.d/T27731 - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - testsuite/tests/typecheck/should_fail/FunDepOrigin1b.hs - + testsuite/tests/typecheck/should_fail/T18851e.hs - + testsuite/tests/typecheck/should_fail/T18851e.stderr - + testsuite/tests/typecheck/should_fail/T27731.hs - + testsuite/tests/typecheck/should_fail/T27731.stderr - testsuite/tests/typecheck/should_fail/all.T Changes: ===================================== changelog.d/T27731 ===================================== @@ -0,0 +1,11 @@ +section: compiler +synopsis: Fix a compiler crash after typechecking +issues: #27731 +mrs: !16564 +description: { + The type checker was failing to report an error, even though it had found one, + due to over-zealous error suppression. That led to subsequent chaos. This + MR fixes it *and* simplifies the code. + + Claude found a second, closely-related bug, now immortalised as test ``T18851d``. +} ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -263,11 +263,11 @@ report_unsolved type_errors expr_holes , cec_type_holes = type_holes , cec_out_of_scope_holes = out_of_scope_holes , cec_suppress = insolubleWC wanted - -- See Note [Suppressing error messages] - -- Suppress low-priority errors if there - -- are insoluble errors anywhere; - -- See #15539 and c.f. setting ic_status - -- in GHC.Tc.Solver.setImplicationStatus + -- See (SLIE1) in + -- Note [cec_suppress: suppressing less-important error messages] + -- Suppress low-priority errors if there are insoluble errors + -- anywhere in the treee. See #15539 and c.f. setting ic_status + -- in GHC.Tc.Solver.setImplicationStatus , cec_warn_redundant = warn_redundant , cec_expand_syns = exp_syns , cec_binds = binds_var } @@ -322,30 +322,121 @@ we just switch off deferred type errors altogether. See #14605. This is done by maybeSwitchOffDefer. It's also useful in one other place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver. -Note [Suppressing error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The cec_suppress flag says "don't report any errors". Instead, just create -evidence bindings (as usual). It's used when more important errors have occurred. - -Specifically (see reportWanteds) - * If there are insoluble Givens, then we are in unreachable code and all bets - are off. So don't report any further errors. - * If there are any insolubles (eg Int~Bool), here or in a nested implication, - then suppress errors from the simple constraints here. Sometimes the - simple-constraint errors are a knock-on effect of the insolubles. - -This suppression behaviour is controlled by the Bool flag in -ReportErrorSpec, as used in reportWanteds. - -But we need to take care: flags can turn errors into warnings, and we -don't want those warnings to suppress subsequent errors (including -suppressing the essential addTcEvBind for them: #15152). So in -tryReporter we use askNoErrs to see if any error messages were -/actually/ produced; if not, we don't switch on suppression. - -A consequence is that warnings never suppress warnings, so turning an -error into a warning may allow subsequent warnings to appear that were -previously suppressed. (e.g. partial-sigs/should_fail/T14584) +Note [cec_suppress: suppressing less-important error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The cec_suppress flag says "don't report any less-important errors". Instead, just create +evidence bindings (as usual). It's used when more important errors have occurred +(or will occur) eleswhere. + +(SLIE0) + * Note that `cec_suppress` does not affect more-important errors, namely the `report1` + group in `reportWanteds` + * But `cec_suppress` /does/ affect the less-important errors, namely the `report2` group. + To see this, look at the plumbing of cec suppress in `reportWanteds` + +(SLIE1) When we begin `reportAllUnsolved` we set `cec_suppress` if there are insoluble + wanteds /anywhere/ in the tree, via `insolubleWC`. That means we'll suppress all + less-important errors in favour of the more important (insolbule) ones + +(SLIE2) But we need to take care: flags can turn errors into warnings, and we + don't want those warnings to suppress subsequent errors (including + suppressing the essential addTcEvBind for them: #15152). So in + tryReporter we use askNoErrs to see if any error messages were + /actually/ produced; if not, we don't switch on suppression. + + A consequence is that warnings never suppress warnings, so turning an + error into a warning may allow subsequent warnings to appear that were + previously suppressed. (e.g. partial-sigs/should_fail/T14584) + +(SLIE3) There is a tricky interaction between + * `cec_suppress` (a global flag) and + * `ei_suppress` (a local, per-error-item flag), + see Note [ei_suppress: suppressing confusing errors] + Suppose cec_suppress is True because of an insoluble constraint arising from a + superclass constraint -- this constraint will have ei_suppress=True. + +Note [ei_suppress: suppressing confusing errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Certain errors we might encounter are potentially confusing to users. +If there are any other errors to report, at all, we want to suppress these. +We achieve this by setting the `ei_suppress` flag in the `ErrorItem`. + +Which errors should be suppressed? + +(SCE1) Non-empty rewriter sets. See Note [Wanteds rewrite Wanteds: rewriter-sets] + in GHC.Tc.Types.Constraint + +(SCE2) Superclasses of Wanteds. These are generated only in case they trigger functional + dependencies. If such a constraint is unsolved, then its "parent" constraint must + also be unsolved, and is much more informative to the user. Example (#26255): + class (MinVersion <= F era) => Era era where { ... } + f :: forall era. EraFamily era -> IO () + f = ..blah... -- [W] Era era + Here we have simply omitted "Era era =>" from f's type. But we'll end up with + /two/ Wanted constraints: + [W] d1 : Era era + [W] d2 : MinVersion <= F era -- Superclass of d1 + We definitely want to report d1 and not d2! Happily it's easy to filter out those + superclass-Wanteds, becuase their Origin betrays them. + +There are wrinkles + +(SCE3) In rare cases we may suppress /all/ errors. That is catastrophic: GHC proceeds + to desugar and optimise the program, even though it is full of type errors (#22702, + #22793), and/or we fail to bind evidence (#27731). + + If this happens, unless we are sure that an error will be reported some other way + (details in the defn of `tidy_items` in `reportWanteds), we just un-suppress the lot, + which is brutal but safe. It's a rare case. + + How can it happen that there are /all/ errors are suppressed? + * See test T18851 for an example of how it is (just, barely) possible for the + /only/ errors to be superclass-of-Wanted constraints. + * Similarly #27731, which also involves a superclass-of-Wanted: + class (a ~ F b) => Ren a b + If we have a [W] Ren a b, we'll emit the superclass [W] a ~ F b, which will + rewrite the original class constraint to [W] Ren (F b) b. Now we have two + constraints: one has a non-empty rewriter set (SEC1) and one is a superclass of + a Wanted (SEC2). + * Also see Wrinkle (PER2) in Note [Prioritise Wanteds with empty + CoHoleSet] in GHC.Tc.Types.Constraint. + +Historical note. We used to suppress errors arising from the interaction of two + fundep constraints. But nowadays fundep constraints never "escape" into the main + solver and so never show up in error messages. See (SOLVE-FD) in Note [Overview + of functional dependencies in type inference] in GHC.Tc.Solver.FunDeps. So this + wrinkle is now just a historical note. + + Errors which arise from the interaction of two Wanted fun-dep constraints. + Example: + + class C a b | a -> b where + op :: a -> b -> b + + foo _ = op True Nothing + + bar _ = op False [] + + Here, we could infer + foo :: C Bool (Maybe a) => p -> Maybe a + bar :: C Bool [a] => p -> [a] + + (The unused arguments suppress the monomorphism restriction.) The problem + is that these types can't both be correct, as they violate the functional + dependency. Yet reporting an error here is awkward: we must + non-deterministically choose either foo or bar to reject. We thus want + to report this problem only when there is nothing else to report. + See typecheck/should_fail/T13506 for an example of when to suppress + the error. The case above is actually accepted, because foo and bar + are checked separately, and thus the two fundep constraints never + encounter each other. It is test case typecheck/should_compile/FunDepOrigin1. + + This case applies only when both fundeps are *Wanted* fundeps; when + both are givens, the error represents unreachable code. For + a Given/Wanted case, see #9612. + + End of historical note + -} reportImplic :: SolverReportErrCtxt -> Implication -> TcM () @@ -452,16 +543,6 @@ reportBadTelescope ctxt env (ForAllSkol telescope) skols reportBadTelescope _ _ skol_info skols = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) --- | Should we completely ignore this constraint in error reporting? --- It *must* be the case that any constraint for which this returns True --- somehow causes an error to be reported elsewhere. --- See Note [Constraints to ignore]. -ignoreConstraint :: Ct -> Bool -ignoreConstraint ct - = case ctOrigin ct of - AssocFamPatOrigin -> True -- See (CIG1) - _ -> False - -- | Makes an error item from a constraint, calculating whether or not the item -- should be suppressed. See Note [Wanteds rewrite Wanteds: rewriter-sets] -- in GHC.Tc.Types.Constraint. Returns Nothing if we should just ignore @@ -473,56 +554,105 @@ mkErrorItem ct ; return Nothing } -- See Note [Constraints to ignore] | otherwise - = do { let loc = ctLoc ct - flav = ctFlavour ct + = do { let ev = ctEvidence ct + + m_evdest = case ev of + CtGiven {} -> Nothing + CtWanted (WantedCt { ctev_dest = dest }) -> Just dest - -- For this `suppress` stuff see - -- Note [Wanteds rewrite Wanteds: rewriter-sets] in GHC.Tc.Types.Constraint - (suppress, m_evdest) = case ctEvidence ct of - CtGiven {} -> (False, Nothing) - CtWanted (WantedCt { ctev_rewriters = rws, ctev_dest = dest }) - -> (not (isEmptyCoHoleSet rws), Just dest) - ; let m_reason = case ct of + m_reason = case ct of CIrredCan (IrredCt { ir_reason = reason }) -> Just reason _ -> Nothing - insoluble_ct = insolubleCt ct - ; return $ Just $ EI { ei_pred = ctPred ct , ei_evdest = m_evdest - , ei_flavour = flav - , ei_loc = loc + , ei_flavour = ctFlavour ct + , ei_loc = ctLoc ct , ei_m_reason = m_reason - , ei_insoluble = insoluble_ct - , ei_suppress = suppress }} + , ei_insoluble = insolubleCt ct + , ei_suppress = suppressCtError ev }} -- | Actually report this 'ErrorItem'. unsuppressErrorItem :: ErrorItem -> ErrorItem unsuppressErrorItem ei = ei { ei_suppress = False } +-- | Should we completely ignore this constraint in error reporting? +-- It *must* be the case that any constraint for which this returns True +-- somehow causes an error to be reported elsewhere. +-- See Note [Constraints to ignore]. +ignoreConstraint :: Ct -> Bool +ignoreConstraint ct + = case ctOrigin ct of + AssocFamPatOrigin -> True -- See (CIG1) + _ -> False + +suppressCtError :: CtEvidence -> Bool +-- See Note [ei_suppress: suppressing confusing errors] +suppressCtError (CtGiven {}) + = False +suppressCtError (CtWanted (WantedCt { ctev_rewriters = rws, ctev_loc = loc })) + | not (isEmptyCoHoleSet rws) + = True -- See (SCE1) + + | isWantedSuperclassOrigin (ctLocOrigin loc) + = True -- See (SCE2) + + | otherwise + = False + +{- Note [Constraints to ignore] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some constraints are meant only to aid the solver by unification; a failure +to solve them is not necessarily an error to report to the user. It is critical +that compilation is aborted elsewhere if there are any ignored constraints here; +they will remain unfilled, and might have been used to rewrite another constraint. + +Currently, the constraints to ignore are: + +(CIG1) Constraints generated in order to unify associated type instance parameters + with class parameters. Here are two illustrative examples: + + class C (a :: k) where + type F (b :: k) + + instance C True where + type F a = Int + + instance C Left where + type F (Left :: a -> Either a b) = Bool + + In the first instance, we want to infer that `a` has type Bool. So we emit + a constraint unifying kappa (the guessed type of `a`) with Bool. All is well. + + In the second instance, we process the associated type instance only + after fixing the quantified type variables of the class instance. We thus + have skolems a1 and b1 such that the class instance is for (Left :: a1 -> Either a1 b1). + Unifying a1 and b1 with a and b in the type instance will fail, but harmlessly so. + checkConsistentFamInst checks for this, and will fail if anything has gone + awry. Really the equality constraints emitted are just meant as an aid, not + a requirement. This is test case T13972. + + We detect this case by looking for an origin of AssocFamPatOrigin; constraints + with this origin are dropped entirely during error message reporting. + + If there is any trouble, checkValidFamInst bleats, aborting compilation. + +(Note: Aug 25: this seems a rather tricky corner; + c.f. Note [ei_suppress: suppressing confusing errors]) +-} + ---------------------------------------------------------------- reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics , wc_errors = errs }) - | isEmptyWC wc = traceTc "reportWanteds empty WC" empty + | isEmptyWC wc + = traceTc "reportWanteds empty WC" empty | otherwise = do { tidy_items1 <- mapMaybeM mkErrorItem tidy_cts - ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples - , text "Suppress =" <+> ppr (cec_suppress ctxt) - , text "tidy_cts =" <+> ppr tidy_cts - , text "tidy_items1 =" <+> ppr tidy_items1 - , text "tidy_errs =" <+> ppr tidy_errs ]) -- Catch an awkward (and probably rare) case in which /all/ errors are - -- suppressed: see Wrinkle (PER2) in Note [Prioritise Wanteds with empty - -- CoHoleSet] in GHC.Tc.Types.Constraint. - -- - -- Unless we are sure that an error will be reported some other way - -- (details in the defn of tidy_items) un-suppress the lot. This makes - -- sure we don't forget to report an error at all, which is - -- catastrophic: GHC proceeds to desguar and optimise the program, even - -- though it is full of type errors (#22702, #22793) + -- suppressed: see (SCE3) in Note [ei_suppress: suppressing confusing errors] ; errs_already <- ifErrsM (return True) (return False) ; let tidy_items | not errs_already -- Have not already reported an error (perhaps @@ -530,43 +660,54 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics , not (any ignoreConstraint simples) -- No error is ignorable (is reported elsewhere) , all ei_suppress tidy_items1 -- All errors are suppressed = map unsuppressErrorItem tidy_items1 + | otherwise = tidy_items1 + ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples + , text "Suppress =" <+> ppr (cec_suppress ctxt) + , text "tidy_cts =" <+> ppr tidy_cts + , text "tidy_items1 =" <+> ppr tidy_items1 + , text "tidy_errs =" <+> ppr tidy_errs ]) + -- First, deal with any out-of-scope errors: ; let (out_of_scope, other_holes, not_conc_errs, mult_co_errs) = partition_errors tidy_errs - -- don't suppress out-of-scope errors + -- Don't suppress out-of-scope errors + -- See (SLIE0) in Note [cec_suppress: suppressing less-important error messages] ctxt_for_scope_errs = ctxt { cec_suppress = False } ; (_, no_out_of_scope) <- askNoErrs $ reportHoles tidy_items ctxt_for_scope_errs out_of_scope -- Next, deal with things that are utterly wrong - -- Like Int ~ Bool (incl nullary TyCons) - -- or Int ~ t a (AppTy on one side) - -- These /ones/ are not suppressed by the incoming context - -- (but will be by out-of-scope errors) + -- These should not be suppressed by the incoming context + -- (but should be suppressed by out-of-scope errors) + -- See (SLIE0) in Note [cec_suppress: suppressing less-important error messages] ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope } - ; reportHoles tidy_items ctxt_for_insols other_holes - -- holes never suppress + -- Don't suppress holes or concreteness errors unless we have scope errors + ; reportHoles tidy_items ctxt_for_insols other_holes ; reportNotConcreteErrs ctxt_for_insols not_conc_errs -- We only want to report multiplicity coercion errors for multiplicity -- constraints which are /solved/ with a non-reflexivity coercion. We -- over approximate here: we only report multiplicity coercion errors - -- when /all/ constraints are solved. + -- when /all/ other constraints are solved. -- See wrinkle (DME1) in Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify. - ; when (null simples) $ reportMultiplicityCoercionErrs ctxt_for_insols mult_co_errs + ; when (null simples) $ + reportMultiplicityCoercionErrs ctxt_for_insols mult_co_errs - -- See Note [Suppressing confusing errors] - ; let (suppressed_items, reportable_items) = partition suppressItem tidy_items - ; traceTc "reportWanteds suppressed:" (ppr suppressed_items) - ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 reportable_items + -- Now the main batch of utterly-wrong things + -- Like Int ~ Bool (incl nullary TyCons) + -- or Int ~ t a (AppTy on one side) + ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 tidy_items -- Now all the other constraints. We suppress errors here if - -- any of the first batch failed, or if the enclosing context - -- says to suppress - ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } + -- any of the first batch failed (ctxt1), or if the enclosing context + -- says to suppress AND there are no local insolubles + -- Why the AND part? In case all those local insolubles are suppressed. + -- See (SLIE3) in Note [cec_suppress: suppressing less-important error messages] + ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt1 + || (cec_suppress ctxt && not (any ei_insoluble tidy_items)) } ; (_, leftovers) <- tryReporters ctxt2 report2 items1 ; massertPpr (null leftovers) (text "The following unsolved Wanted constraints \ @@ -577,21 +718,10 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- NB ctxt2: don't suppress inner insolubles if there's only a -- wanted insoluble here; but do suppress inner insolubles -- if there's a *given* insoluble here (= inaccessible code) - - -- If there are no other errors to report, report suppressed errors. - -- See (SCE3) in Note [Suppressing confusing errors]. - -- NB: with -fdefer-type-errors we might have reported warnings only from - -- reportable_items`, but we still want to suppress the `suppressed_items`. - ; when (null reportable_items) $ - do { (_, more_leftovers) <- tryReporters ctxt_for_insols (report1++report2) - suppressed_items - -- ctxt_for_insols: the suppressed errors can be Int~Bool, which - -- will have made the incoming `ctxt` be True; don't make that - -- suppress the Int~Bool error! - ; massertPpr (null more_leftovers) (ppr more_leftovers) } } + } where env = cec_tidy ctxt - tidy_cts = bagToList (mapBag (tidyCt env) simples) + tidy_cts = bagToList (mapBag (tidyCt env) simples) tidy_errs = bagToList (mapBag (tidyDelayedError env) errs) partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError], [(TcCoercion, CtLoc)]) @@ -610,8 +740,8 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics DE_Multiplicity mult_co loc -> (es1, es2, es3, (mult_co, loc):es4) - -- report1: ones that should *not* be suppressed by - -- an insoluble somewhere else in the tree + -- report1: ones that should *not* be suppressed by cec_suppress, + -- (i.e. by an insoluble somewhere else in the tree) -- It's crucial that anything that is considered insoluble -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise -- we might suppress its error message, and proceed on past @@ -752,15 +882,6 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics = has_gadt_match implics --------------- -suppressItem :: ErrorItem -> Bool - -- See Note [Suppressing confusing errors] -suppressItem item - | Wanted <- ei_flavour item - , let orig = errorItemOrigin item - = isWantedSuperclassOrigin orig -- See (SCE1) - | otherwise - = False - isSkolemTy :: TcLevel -> Type -> Bool -- The type is a skolem tyvar isSkolemTy tc_lvl ty @@ -778,113 +899,8 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of Just (tc,_) | isTypeFamilyTyCon tc -> Just tc _ -> Nothing -{- Note [Suppressing confusing errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Certain errors we might encounter are potentially confusing to users. -If there are any other errors to report, at all, we want to suppress these. - -Which errors should be suppressed? - -(SCE1) Superclasses of Wanteds. These are generated only in case they trigger functional - dependencies. If such a constraint is unsolved, then its "parent" constraint must - also be unsolved, and is much more informative to the user. Example (#26255): - class (MinVersion <= F era) => Era era where { ... } - f :: forall era. EraFamily era -> IO () - f = ..blah... -- [W] Era era - Here we have simply omitted "Era era =>" from f's type. But we'll end up with - /two/ Wanted constraints: - [W] d1 : Era era - [W] d2 : MinVersion <= F era -- Superclass of d1 - We definitely want to report d1 and not d2! Happily it's easy to filter out those - superclass-Wanteds, becuase their Origin betrays them. - -Historical (SCE2). Fundep constraints never "escape" into the - main solver and so never show up in error messages. - See (SOLVE-FD) in Note [Overview of functional dependencies in type inference] - in GHC.Tc.Solver.FunDeps. So this wrinkle is now just a historical note. - - Errors which arise from the interaction of two Wanted fun-dep constraints. - Example: - - class C a b | a -> b where - op :: a -> b -> b - - foo _ = op True Nothing - - bar _ = op False [] - - Here, we could infer - foo :: C Bool (Maybe a) => p -> Maybe a - bar :: C Bool [a] => p -> [a] - - (The unused arguments suppress the monomorphism restriction.) The problem - is that these types can't both be correct, as they violate the functional - dependency. Yet reporting an error here is awkward: we must - non-deterministically choose either foo or bar to reject. We thus want - to report this problem only when there is nothing else to report. - See typecheck/should_fail/T13506 for an example of when to suppress - the error. The case above is actually accepted, because foo and bar - are checked separately, and thus the two fundep constraints never - encounter each other. It is test case typecheck/should_compile/FunDepOrigin1. - - This case applies only when both fundeps are *Wanted* fundeps; when - both are givens, the error represents unreachable code. For - a Given/Wanted case, see #9612. - - End of historical (SCE2) - -(SCE3) How can it happen that there are /only/ suppressed errors? See test T18851 - for an example of how it is (just, barely) possible for the /only/ errors to - be superclass-of-Wanted constraints. - -Mechanism: - -We use the `suppress` function within reportWanteds to filter out these -"suppress" cases, then report all other errors. After doing so, we return to these -suppressed ones and report them only if there have been no errors so far. - -Note [Constraints to ignore] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some constraints are meant only to aid the solver by unification; a failure -to solve them is not necessarily an error to report to the user. It is critical -that compilation is aborted elsewhere if there are any ignored constraints here; -they will remain unfilled, and might have been used to rewrite another constraint. - -Currently, the constraints to ignore are: - -(CIG1) Constraints generated in order to unify associated type instance parameters - with class parameters. Here are two illustrative examples: - - class C (a :: k) where - type F (b :: k) - - instance C True where - type F a = Int - - instance C Left where - type F (Left :: a -> Either a b) = Bool - - In the first instance, we want to infer that `a` has type Bool. So we emit - a constraint unifying kappa (the guessed type of `a`) with Bool. All is well. - - In the second instance, we process the associated type instance only - after fixing the quantified type variables of the class instance. We thus - have skolems a1 and b1 such that the class instance is for (Left :: a1 -> Either a1 b1). - Unifying a1 and b1 with a and b in the type instance will fail, but harmlessly so. - checkConsistentFamInst checks for this, and will fail if anything has gone - awry. Really the equality constraints emitted are just meant as an aid, not - a requirement. This is test case T13972. - - We detect this case by looking for an origin of AssocFamPatOrigin; constraints - with this origin are dropped entirely during error message reporting. - - If there is any trouble, checkValidFamInst bleats, aborting compilation. - -(Note: Aug 25: this seems a rather tricky corner; - c.f. Note [Suppressing confusing errors]) - -Note [Implementation of Unsatisfiable constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Implementation of Unsatisfiable constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Unsatisfiable constraint was introduced in GHC proposal #433 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-u…) See Note [The Unsatisfiable constraint] in GHC.TypeError. @@ -1317,9 +1333,15 @@ maybeReportError :: SolverReportErrCtxt maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = important , sr_supplementary = supp , sr_hints = hints }) - | suppress_group = return () - | otherwise = do { msg <- mkErrorReport loc_env diag (Just ctxt) supp hints - ; reportDiagnostic msg } + | suppress_group + = -- Suppress the report entirely + -- But NB we still create the evidence binding; see `reportGroup`. + return () + + | otherwise + = -- Spit out an error or warning + do { msg <- mkErrorReport loc_env diag (Just ctxt) supp hints + ; reportDiagnostic msg } where reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag | otherwise = cec_defer_type_errors ctxt @@ -1328,11 +1350,6 @@ maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = import loc_env = ctLocEnv (errorItemCtLoc item1) suppress_group - | all ei_suppress items - = True -- If they are all suppressed (notably, have been rewritten by another unsolved wanted) - -- report nothing. (If at least one is not suppressed, do report: the function that - -- generates the error message should look for an unsuppressed error item.) - -- It is tempting to say that we always want to see all insoluble errors -- But then we get a bit more than we want. Examples: -- a ~ t a occurs check errors (T2534, mc25) @@ -1344,6 +1361,12 @@ maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = import | cec_suppress ctxt = True -- Some earlier error has occurred, so suppress this diagnostic + | all ei_suppress items + = True -- If they are all suppressed (notably, have been rewritten by another unsolved + -- wanted) report nothing. (If at least one is not suppressed, do report: + -- the function that generates the error message should look for an + -- unsuppressed error item.) + | otherwise = False @@ -1402,11 +1425,11 @@ mkErrorTerm ct_loc ty ctxt msg supp hints ; return $ evDelayedError ty err_str } -tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) +tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] + -> TcM (SolverReportErrCtxt, [ErrorItem]) -- Use the first reporter in the list whose predicate says True tryReporters ctxt reporters items - = do { let (vis_items, invis_items) - = partition (isVisibleOrigin . errorItemOrigin) items + = do { let (vis_items, invis_items) = partition (isVisibleOrigin . errorItemOrigin) items ; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items) ; (ctxt', items') <- go ctxt reporters vis_items invis_items ; traceTc "tryReporters }" (ppr items') @@ -1416,9 +1439,9 @@ tryReporters ctxt reporters items = return (ctxt, vis_items ++ invis_items) go ctxt (r : rs) vis_items invis_items - -- always look at *visible* Origins before invisible ones + -- Always look at *visible* Origins before invisible ones -- this is the whole point of isVisibleOrigin - = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items + = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items ; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items ; go ctxt'' rs vis_items' invis_items' } -- Carry on with the rest, because we must make @@ -1432,7 +1455,7 @@ tryReporter ctxt (str, keep_me, suppress_after, reporter) items = case nonEmpty { traceTc "tryReporter{ " (text str <+> ppr yeses) ; (_, no_errs) <- askNoErrs (reporter ctxt yeses) ; let suppress_now = not no_errs && suppress_after - -- See Note [Suppressing error messages] + -- See (SLIE2) in Note [cec_suppress: suppressing less-important error messages] ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) ; return (ctxt', nos) } ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -5477,7 +5477,7 @@ data SolverReportErrCtxt , cec_suppress :: Bool -- ^ True <=> More important errors have occurred, -- so create bindings if need be, but -- don't issue any more errors/warnings - -- See Note [Suppressing error messages] + -- See Note [cec_suppress: suppressing less-important error messages] } ---------------------------------------------------------------------------- ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -1214,15 +1214,16 @@ insolubleWantedCt :: Ct -> Bool -- -- See Note [Insoluble Wanteds] insolubleWantedCt ct - | CtWanted (WantedCt { ctev_loc = loc, ctev_rewriters = rewriters }) - <- ctEvidence ct + | CtWanted (WantedCt {}) <- ctEvidence ct -- It's a Wanted , insolubleCt ct -- It's insoluble - , isEmptyCoHoleSet rewriters +-- , isEmptyCoHoleSet rewriters -- It has no rewriters – see (IW1) in Note [Insoluble Wanteds] - , not (isGivenLoc loc) - -- isGivenLoc: see (IW2) in Note [Insoluble Wanteds] + +-- I don't understand IW2 so I'm going to get rid of it +-- , not (isGivenLoc loc) +-- -- isGivenLoc: see (IW2) in Note [Insoluble Wanteds] -- See also historical (IW3) in Note [Insoluble Wanteds] = True ===================================== testsuite/tests/typecheck/should_fail/FunDepOrigin1b.hs ===================================== @@ -8,4 +8,4 @@ class C a b | a -> b where -- foo :: (C Bool (Maybe a), C Bool [b]) => x -> (Maybe a, [b]) foo _ = (op True Nothing, op False []) --- See Note [Suppressing confusing errors] in GHC.Tc.Errors +-- See Note [ei_suppress: suppressing confusing errors] in GHC.Tc.Errors ===================================== testsuite/tests/typecheck/should_fail/T18851e.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE FunctionalDependencies, FlexibleInstances, UndecidableInstances, + ScopedTypeVariables, TypeFamilies, TypeApplications, + FlexibleContexts, AllowAmbiguousTypes, ExtendedDefaultRules #-} + +module T18851e where + +default (Int) + +type family C_FD a +class C_FD a ~ b => C a b + +type instance C_FD Int = Bool -- just for Show (C_FD Int) +instance C Int b => C Int b + +class IsInt int +instance int ~ Int => IsInt int + +data A +instance Show A where + show _ = "A" +data B +instance Show B where + show _ = "B" + +data D + +f :: forall a b c int + . ( Show c, Num int + , C int a, C int b, C int c + -- , c ~ C_FD int -- add this to get rid of ambiguity error + ) + => String +f = show (undefined :: c) + +g :: String +g = f @A @B ++ show (undefined :: D) + -- This variant, suggested by Claude in a review of !16564, + -- has an unsolved (Show D) constraint. It must not be suppressed + -- by the insoluble-but-suppressed constraints arising from (C Int a) ===================================== testsuite/tests/typecheck/should_fail/T18851e.stderr ===================================== @@ -0,0 +1,20 @@ +T18851e.hs:36:5: error: [GHC-39999] + • Ambiguous type variable ‘int0’ arising from a use of ‘f’ + prevents the constraint ‘(Num int0)’ from being solved. + Probable fix: use a type annotation to specify what ‘int0’ should be. + Potentially matching instances: + instance Num Integer -- Defined in ‘GHC.Internal.Num’ + instance Num Double -- Defined in ‘GHC.Internal.Float’ + ...plus three others + ...plus one instance involving out-of-scope types + (use -fprint-potential-instances to see them all) + • In the first argument of ‘(++)’, namely ‘f @A @B’ + In the expression: f @A @B ++ show (undefined :: D) + In an equation for ‘g’: g = f @A @B ++ show (undefined :: D) + +T18851e.hs:36:17: error: [GHC-39999] + • No instance for ‘Show D’ arising from a use of ‘show’ + • In the second argument of ‘(++)’, namely ‘show (undefined :: D)’ + In the expression: f @A @B ++ show (undefined :: D) + In an equation for ‘g’: g = f @A @B ++ show (undefined :: D) + ===================================== testsuite/tests/typecheck/should_fail/T27731.hs ===================================== @@ -0,0 +1,36 @@ +{-# LANGUAGE ImplicitParams, TypeFamilies #-} + +module Bug where + +type family St (a :: k) :: * +type family Ev (a :: k) :: * -> * + +data T1 a = C1 a +data T2 h g = C2 (h ()) + +class (h ~ Ev g, s ~ St g) => Ren s h g + +f1 :: + (s ~ St h, Ren s h g, ?settings :: settings) + => (g v -> g ()) -> g v -> g () +f1 form = (\_ a -> a) (C1 (f2 {-@g-})) form + +f2 :: forall g h s. ( s ~ St h, Ren s h g) => T2 h g +f2 = error "urk" + +{- Call of f2 + +[W] s ~ St h --> St g ~ St h --> St g ~ St (Ev g) +[W] Ren s h g +[W] s ~ St g -- Superclass of wanted +[W] h ~ Ev g -- Superclass of wanted +-} + +{- +f3 :: + T1 () + -> (g v -> g ()) + -> g v -> g () +f3 wd form = ((\_ a -> a) wd form) + +-} ===================================== testsuite/tests/typecheck/should_fail/T27731.stderr ===================================== @@ -0,0 +1,16 @@ +T27731.hs:16:28: [GHC-05617] + • Could not deduce ‘St (Ev g0) ~ St g0’ + arising from a superclass required to satisfy ‘Ren + (St (Ev g0)) (Ev g0) g0’, + arising from a use of ‘f2’ + from the context: (s ~ St h, Ren s h g, ?settings::settings) + bound by the type signature for: + f1 :: forall s (h :: * -> *) (g :: * -> *) settings v. + (s ~ St h, Ren s h g, ?settings::settings) => + (g v -> g ()) -> g v -> g () + at T27731.hs:(13,1)-(15,33) + Note: ‘St’ is a non-injective type family. + The type variable ‘g0’ is ambiguous + • In the first argument of ‘C1’, namely ‘(f2)’ + In the first argument of ‘\ _ a -> a’, namely ‘(C1 (f2))’ + In the expression: (\ _ a -> a) (C1 (f2)) form ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -565,6 +565,7 @@ test('T17563', normal, compile_fail, ['']) test('T18851', normal, compile_fail, ['']) test('T18851b', normal, compile, ['']) test('T18851c', normal, compile, ['']) +test('T18851e', normal, compile_fail, ['']) test('T16946', normal, compile_fail, ['']) test('T16502', expect_broken(12854), compile, ['']) test('T17566b', normal, compile_fail, ['']) @@ -763,3 +764,4 @@ test('T26861', normal, compile_fail, ['']) test('T26862', normal, compile_fail, ['']) test('T27210', normal, compile_fail, ['']) test('T26532', normal, compile_fail, ['']) +test('T27731', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/46482c15c020310f6256925eba6341f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/46482c15c020310f6256925eba6341f… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0