Florian Ragwitz pushed to branch wip/rafl/hpc-instances 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 - - - - - c673ecf0 by Simon Peyton Jones at 2026-09-05T07:22:59-04:00 Move HsStatic free-var test to typechecker A `static` form should have no free *term* variables, but it can have free *type* variables. Alas, the renamer does not really know what is a term variable and what is a type variable, because of required type arguments. This patch moves the test to the typechecker, which does know. Addresses #27664 - - - - - e25a36da by Florian Ragwitz at 2026-09-05T09:41:05-07:00 hpc: Test desired HPC behaviour for class instances - - - - - 0c833d17 by Florian Ragwitz at 2026-09-05T09:41:06-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. - - - - - ee6519e6 by Florian Ragwitz at 2026-09-05T09:41:06-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. - - - - - 3a176ec9 by Florian Ragwitz at 2026-09-05T09:41:06-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. - - - - - 97292cee by Florian Ragwitz at 2026-09-05T09:41:06-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. - - - - - 6317c95a by Florian Ragwitz at 2026-09-05T09:41:06-07:00 Add a changelog entry for new HPC features - - - - - 28 changed files: - + changelog.d/T27764 - + changelog.d/hpc-classinsts - + 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 - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Tc/Gen/Expr.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/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 - + testsuite/tests/hpc/instmeths/instmeths.hs - + testsuite/tests/hpc/instmeths/instmeths.stdout - + testsuite/tests/hpc/instmeths/test.T - testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr - testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr - testsuite/tests/rename/should_fail/T26545.stderr - + testsuite/tests/typecheck/should_compile/T27664.hs - testsuite/tests/typecheck/should_compile/all.T Changes: ===================================== changelog.d/T27764 ===================================== @@ -0,0 +1,8 @@ +section: compiler +synopsis: Fix bug in ``static`` forms +issues: #27664 +mrs: !16624 +description: A ``static`` form should have no free *term* variables, but it + can have free *type* variables. Alas, the renamer does not really know what + is a term variable and what is a type variable, because of required type + arguments. This patch moves the test to the typechecker, which does know. ===================================== 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 ===================================== 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 ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -39,6 +39,7 @@ import GHC.Tc.Types.ErrCtxt import GHC.Types.Id.Info ( RecSelParent ) import GHC.Types.Name import GHC.Types.Name.Reader +import GHC.Types.Name.Set( FreeNames ) import GHC.Types.Basic import GHC.Types.Fixity import GHC.Types.SourceText @@ -363,7 +364,9 @@ type instance XArithSeq GhcTc = PostTcExpr type instance XProc (GhcPass _) = (EpToken "proc", TokRarrow) type instance XStatic GhcPs = EpToken "static" -type instance XStatic GhcRn = NoExtField +type instance XStatic GhcRn = FreeNames + -- Free variables of the body; we can't tell if they are + -- type or term variables until we are typechecking type instance XStatic GhcTc = (Type, HsExpr GhcTc) -- Type of expression, and the (fromStaticPtr function) -- These are stored for convenience as the wiring in ===================================== 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/Rename/Expr.hs ===================================== @@ -667,18 +667,7 @@ rnExpr e@(HsStatic _ expr) -- Rename the payload ; (expr',fvs) <- rnLExpr expr - -- Check that the free variables of the static form are top-level defined - -- It's OK to use nonDetEltsUniqSet here as the only side effects of - -- checkClosedInStaticForm are error messages. - -- See (SF2) Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable - ; mapM_ check_fv (nonDetEltsUniqSet fvs) - - ; return (HsStatic noExtField expr', fvs) } - where - check_fv :: Name -> RnM () - -- Check for free vars not defined at top level - check_fv n = unless (isExternalName n) $ - addErrTc (TcRnStaticFormNotClosed n) + ; return (HsStatic fvs expr', fvs) } {- ************************************************************************ ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -602,13 +602,19 @@ tcExpr (HsProc x pat cmd) res_ty -- and wrap (static e) in a call to -- fromStaticPtr :: IsStatic p => StaticPtr a -> p a -tcExpr (HsStatic _ expr) res_ty +tcExpr (HsStatic free_names expr) res_ty = do { res_ty <- expTypeToType res_ty ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty ; (expr', lie) <- captureConstraints $ addErrCtxt (StaticFormCtxt expr) $ tcCheckPolyExprNC expr expr_ty + -- Check that the free variables of the static form are top-level defined + -- It's OK to use nonDetEltsUniqSet here as the only side effects of + -- checkClosedInStaticForm are error messages. + -- See (SF2) Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable + ; mapM_ check_free_name (nonDetEltsUniqSet free_names) + -- Emit an implication that captures the constraints of `expr`, -- but with a `ic_info` of StaticFormSkol -- See #13499 for an explanation of why this is the right thing to do: @@ -637,6 +643,24 @@ tcExpr (HsStatic _ expr) res_ty HsStatic (static_expr_ty, mkHsWrap wrap fromStaticPtr) expr'' } + where + check_free_name :: Name -> TcM () + -- Check for free /term/ vars not defined at top level + -- We use isExternalName as a proxy for top-level-defined + check_free_name n + = do { mb_thing <- tcLookupLcl_maybe n + ; case mb_thing of + Nothing -> return () -- Imports, tycons, classes allowed + Just (ATcId {}) -> unless (isExternalName n) $ + addErrTc (TcRnStaticFormNotClosed n) + + Just (ATyVar {}) -> return () -- Free type variables are allowed + + -- Not really expecting these, but we'll get an error from + -- elsewhere, so don't produce an error here + Just (ATcTyCon {}) -> return () + Just (APromotionErr {}) -> return () + Just (AGlobal {}) -> return () } tcExpr (HsEmbTy _ _) _ = failWith (TcRnIllegalTypeExpr TypeKeywordSyntax) tcExpr (HsQual _ _ _) _ = failWith (TcRnIllegalTypeExpr ContextArrowSyntax) ===================================== 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/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), ===================================== 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']) ===================================== testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr ===================================== @@ -1,3 +1,5 @@ RnStaticPointersFail01.hs:5:7: error: [GHC-88431] - ‘x’ is used in a static form but it is not defined at top level + • ‘x’ is used in a static form but it is not defined at top level + • In the expression: static x + In an equation for ‘f’: f x = static x ===================================== testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr ===================================== @@ -1,12 +1,34 @@ RnStaticPointersFail03.hs:8:7: error: [GHC-88431] - ‘x’ is used in a static form but it is not defined at top level + • ‘x’ is used in a static form but it is not defined at top level + • In the expression: static (x . id) + In an equation for ‘f’: f x = static (x . id) RnStaticPointersFail03.hs:10:8: error: [GHC-88431] - ‘k’ is used in a static form but it is not defined at top level + • ‘k’ is used in a static form but it is not defined at top level + • In the expression: static (k . id) + In an equation for ‘f0’: + f0 x + = static (k . id) + where + k = const (const () x) RnStaticPointersFail03.hs:14:8: error: [GHC-88431] - ‘k’ is used in a static form but it is not defined at top level + • ‘k’ is used in a static form but it is not defined at top level + • In the expression: static (k . id) + In an equation for ‘f1’: + f1 x + = static (k . id) + where + k = id RnStaticPointersFail03.hs:19:15: error: [GHC-88431] - ‘g’ is used in a static form but it is not defined at top level + • ‘g’ is used in a static form but it is not defined at top level + • In the first argument of ‘const’, namely ‘(static (g undefined))’ + In the expression: const (static (g undefined)) (h x) + In an equation for ‘f2’: + f2 x + = const (static (g undefined)) (h x) + where + g = h + h = typeOf ===================================== testsuite/tests/rename/should_fail/T26545.stderr ===================================== @@ -1,3 +1,6 @@ T26545.hs:12:23: error: [GHC-88431] - ‘v’ is used in a static form but it is not defined at top level + • ‘v’ is used in a static form but it is not defined at top level + • In the expression: static (I# (v +# 1#)) + In the expression: let v = f 3# in static (I# (v +# 1#)) + In an equation for ‘h’: h x = let v = f 3# in static (I# (v +# 1#)) ===================================== testsuite/tests/typecheck/should_compile/T27664.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE StaticPointers, ScopedTypeVariables #-} +module Repro where + +import Data.Typeable +import GHC.StaticPtr + +f1 :: forall a. Typeable a => StaticPtr (a -> a) +f1 = static (id :: a -> a) + +f2 :: forall a. Typeable a => StaticPtr (a -> a) +f2 = static (id) :: StaticPtr (a->a) ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -969,3 +969,4 @@ test('ExpansionQLIm', normal, compile, ['']) test('T23135', normal, compile, ['']) test('LazyFieldAnnotations', normal, compile, ['']) test('T27557', normal, compile, ['']) +test('T27664', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c5f3a8570a0b3c1c2c54f09e884c213... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c5f3a8570a0b3c1c2c54f09e884c213... 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