GitLab

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

 +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

 +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

 +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

 +btrq
 +btsq
 +btcq
 +btrl
 +btsl
 +btcl
 +btrq $40,
 +btsq $40,
 +btcq $40,

testsuite/tests/codeGen/should_gen_asm/T25233.hs

 +{-# 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

 +btrq %
 +btsq %
 +btcq %
 +btrq $40,
 +btsq $40,
 +btcq $40,

testsuite/tests/codeGen/should_gen_asm/T25233b.cmm

 +#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

 +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

 +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

 +setTestOpts([omit_ghci, when(fast(), skip), js_skip])
++
 +test('instmeths',
 +     [ignore_extension],
 +     compile_and_run, ['-fhpc'])

testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr

  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

  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

  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

 +{-# 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, [''])