Florian Ragwitz pushed to branch wip/rafl/hpc-pragma at Glasgow Haskell Compiler / GHC

Commits:

13 changed files:

Changes:

  • compiler/GHC/Hs/Expr.hs
    ... ... @@ -618,6 +618,7 @@ instance NoAnn AnnFunRhs where
    618 618 
     -- ---------------------------------------------------------------------
    619 619
    620 620 
     type instance XSCC           (GhcPass _) = (AnnPragSCC, SourceText)
    621 
    +type instance XNoCover       (GhcPass _) = (AnnPragNoCover, SourceText)
    621 622 
     type instance XXPragE        (GhcPass _) = DataConCantHappen
    622 623
    623 624 
     type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel
    ... ... @@ -1258,6 +1259,9 @@ instance Outputable (HsPragE (GhcPass p)) where
    1258 1259 
          -- no doublequotes if stl empty, for the case where the SCC was written
    1259 1260 
          -- without quotes.
    1260 1261 
         <+> pprWithSourceText (stringLitSourceText sl) (ppr lbl) <+> text "#-}"
    1262 
    +  ppr (HsPragNoCover (_, st) sl@(StringLiteral _ lbl)) =
    1263 
    +    pprWithSourceText st (text "{-# NOCOVER")
    1264 
    +    <+> pprWithSourceText (stringLitSourceText sl) (ppr lbl) <+> text "#-}"
    1261 1265
    1262 1266
    1263 1267 
     {- *********************************************************************

  • compiler/GHC/HsToCore/Expr.hs
    ... ... @@ -422,6 +422,8 @@ dsExpr (HsPragE _ (HsPragSCC _ cc) expr)
    422 422 
                      <$> dsLExpr expr
    423 423 
              else dsLExpr expr }
    424 424
    425 
    +dsExpr (HsPragE _ (HsPragNoCover _ _) expr) = dsLExpr expr
    426 
    +
    425 427 
     dsExpr (HsCase ctxt discrim matches)
    426 428 
       = do { core_discrim <- dsLExpr discrim
    427 429 
            ; ([discrim_var], matching_code) <- matchWrapper ctxt (Just [core_discrim]) matches

  • compiler/GHC/HsToCore/Quote.hs
    ... ... @@ -1763,6 +1763,7 @@ repE e@(XExpr (ExpandedThingRn (HSE o x)))
    1763 1763 
       = notHandled (ThExpressionForm e)
    1764 1764 
     repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (mkHsVar (noLocA x))
    1765 1765 
     repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
    1766 
    +repE e@(HsPragE _ (HsPragNoCover{}) _) = notHandled (ThExpressionForm e)
    1766 1767 
     repE e@(HsTypedBracket{})   = notHandled (ThExpressionForm e)
    1767 1768 
     repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)
    1768 1769 
     repE e@(HsProc{}) = notHandled (ThExpressionForm e)

  • compiler/GHC/HsToCore/Ticks.hs
    ... ... @@ -5,7 +5,7 @@
    5 5 
     {-
    6 6 
     (c) Galois, 2006
    7 7 
     (c) University of Glasgow, 2007
    8 
    -(c) Florian Ragwitz, 2025
    8 
    +(c) Florian Ragwitz, 2025-2026
    9 9 
     -}
    10 10
    11 11 
     module GHC.HsToCore.Ticks
    ... ... @@ -420,7 +420,7 @@ addTickLHsExpr e@(L pos e0) = do
    420 420 
         TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
    421 421 
         TickForCoverage    | XExpr (ExpandedThingTc (HSE StmtErrCtxt{} _)) <- e0 -- expansion ticks are handled separately
    422 422 
                            -> dont_tick_it
    423 
    -                       | otherwise -> tick_it
    423 
    +                       | otherwise -> ifCoverageSuppressed e0 dont_tick_it tick_it
    424 424 
         TickCallSites      | isCallSite e0      -> tick_it
    425 425 
         _other             -> dont_tick_it
    426 426 
      where
    ... ... @@ -428,6 +428,17 @@ addTickLHsExpr e@(L pos e0) = do
    428 428 
                       $ addTickHsExpr e0
    429 429 
        dont_tick_it = addTickLHsExprNever e
    430 430
    431 
    +ifCoverageSuppressed :: HsExpr GhcTc -> TM a -> TM a -> TM a
    432 
    +ifCoverageSuppressed e noCover cover
    433 
    +    | isNoCoverExpr e = do
    434 
    +        hpc <- (== HpcTicks) . tickishType <$> getEnv
    435 
    +        if hpc then noCover else cover
    436 
    +    | otherwise = cover
    437 
    +  where
    438 
    +    isNoCoverExpr (HsPragE _ (HsPragNoCover{}) _) = True
    439 
    +    isNoCoverExpr (HsPar _ e) = isNoCoverExpr (unLoc e)
    440 
    +    isNoCoverExpr _ = False
    441 
    +
    431 442 
     -- Add a tick to an expression which is the RHS of an equation or a binding.
    432 443 
     -- We always consider these to be breakpoints, unless the expression is a 'let'
    433 444 
     -- (because the body will definitely have a tick somewhere).  ToDo: perhaps
    ... ... @@ -438,7 +449,7 @@ addTickLHsExprRHS e@(L pos e0) = do
    438 449 
       case d of
    439 450 
          TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
    440 451 
                             | otherwise     -> tick_it
    441 
    -     TickForCoverage -> tick_it
    452 
    +     TickForCoverage -> ifCoverageSuppressed e0 dont_tick_it tick_it
    442 453 
          TickCallSites   | isCallSite e0 -> tick_it
    443 454 
          _other          -> dont_tick_it
    444 455 
      where
    ... ... @@ -503,14 +514,17 @@ isCallSite _ = False
    503 514 
     addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
    504 515 
     addTickLHsExprOptAlt oneOfMany e@(L pos e0)
    505 516 
       = ifDensity TickForCoverage
    506 
    -        (allocTickBox (ExpBox oneOfMany) False False (locA pos)
    507 
    -                           $ addTickHsExpr e0)
    517 
    +        (ifCoverageSuppressed e0
    518 
    +          (addTickLHsExprNever e)
    519 
    +          (allocTickBox (ExpBox oneOfMany) False False (locA pos) $ addTickHsExpr e0))
    508 520 
             (addTickLHsExpr e)
    509 521
    510 522 
     addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
    511 523 
     addBinTickLHsExpr boxLabel e@(L pos e0)
    512 524 
       = ifDensity TickForCoverage
    513 
    -        (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0)
    525 
    +        (ifCoverageSuppressed e0
    526 
    +          (addTickLHsExpr e)
    527 
    +          (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0))
    514 528 
             (addTickLHsExpr e)
    515 529
    516 530
    ... ... @@ -625,8 +639,8 @@ addTickHsExpr (ArithSeq ty wit arith_seq) =
    625 639 
                        addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
    626 640 
                                                  return (Just fl')
    627 641
    628 
    -addTickHsExpr (HsPragE x p e) =
    629 
    -        liftM (HsPragE x p) (addTickLHsExpr e)
    642 
    +addTickHsExpr e@(HsPragE x p e') =
    643 
    +  ifCoverageSuppressed e (pure e) (HsPragE x p <$> addTickLHsExpr e')
    630 644 
     addTickHsExpr e@(HsTypedBracket {})  = return e
    631 645 
     addTickHsExpr e@(HsUntypedBracket{}) = return e
    632 646 
     addTickHsExpr e@(HsTypedSplice{})    = return e

  • compiler/GHC/Parser.y
    ... ... @@ -655,6 +655,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
    655 655 
      '{-# SOURCE'             { L _ (ITsource_prag _) }
    656 656 
      '{-# RULES'              { L _ (ITrules_prag _) }
    657 657 
      '{-# SCC'                { L _ (ITscc_prag _)}
    658 
    + '{-# NOCOVER'            { L _ (ITnocover_prag _)}
    658 659 
      '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }
    659 660 
      '{-# WARNING'            { L _ (ITwarning_prag _) }
    660 661 
      '{-# UNPACK'             { L _ (ITunpack_prag _) }
    ... ... @@ -3062,6 +3063,11 @@ prag_e :: { Located (HsPragE GhcPs) }
    3062 3063 
                                                    (AnnPragSCC (glR $1) (epTok $3) (glR $2),
    3063 3064 
                                                    (getSCC_PRAGs $1))
    3064 3065 
                                                    (StringLiteral NoSourceText (fastStringToShortText $ getVARID $2))) }
    3066 
    +      | '{-# NOCOVER' STRING '#-}'  { sLL $1 $>
    3067 
    +                                             (HsPragNoCover
    3068 
    +                                               (AnnPragNoCover (glR $1) (epTok $3) (glR $2),
    3069 
    +                                               (getNOCOVER_PRAGs $1))
    3070 
    +                                               (StringLiteral (getSTRINGs $2) (getSTRING $2))) }
    3065 3071
    3066 3072 
     fexp    :: { ECP }
    3067 3073 
             : fexp aexp                  { ECP $
    ... ... @@ -4335,6 +4341,7 @@ getRULES_PRAGs (L _ (ITrules_prag src)) = src
    4335 4341 
     getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src
    4336 4342 
     getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src
    4337 4343 
     getSCC_PRAGs          (L _ (ITscc_prag          src)) = src
    4344 
    +getNOCOVER_PRAGs      (L _ (ITnocover_prag          src)) = src
    4338 4345 
     getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src
    4339 4346 
     getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src
    4340 4347 
     getANN_PRAGs          (L _ (ITann_prag          src)) = src

  • compiler/GHC/Parser/Annotation.hs
    ... ... @@ -43,7 +43,7 @@ module GHC.Parser.Annotation (
    43 43
    44 44 
       AnnList(..), AnnListBrackets(..), AnnListLayout(..),
    45 45 
       AnnParen(..),
    46 
    -  AnnCType(..),AnnWarningTxt(..),AnnOverlap(..),AnnAnnDecl(..),AnnPragSCC(..),
    46 
    +  AnnCType(..),AnnWarningTxt(..),AnnOverlap(..),AnnAnnDecl(..),AnnPragSCC(..),AnnPragNoCover(..),
    47 47
    48 48 
       -- ** Utilities for converting between different 'GenLocated' when
    49 49 
       -- ** we do not care about the annotations.
    ... ... @@ -653,6 +653,13 @@ data AnnPragSCC
    653 653 
           aps_loc1      :: EpaLocation
    654 654 
           } deriving (Data,Eq)
    655 655
    656 
    +data AnnPragNoCover
    657 
    +  = AnnPragNoCover {
    658 
    +      apnc_open      :: EpaLocation,
    659 
    +      apnc_close     :: EpToken "#-}",
    660 
    +      apnc_loc1      :: EpaLocation
    661 
    +      } deriving (Data,Eq)
    662 
    +
    656 663 
     -- ---------------------------------------------------------------------
    657 664
    658 665 
     -- | Helper function used in the parser to add a 'TrailingAnn' items
    ... ... @@ -1030,6 +1037,9 @@ instance NoAnn AnnAnnDecl where
    1030 1037 
     instance NoAnn AnnPragSCC where
    1031 1038 
       noAnn = AnnPragSCC noAnn noAnn noAnn
    1032 1039
    1040 
    +instance NoAnn AnnPragNoCover where
    1041 
    +  noAnn = AnnPragNoCover noAnn noAnn noAnn
    1042 
    +
    1033 1043 
     instance NoAnn AnnParen where
    1034 1044 
       noAnn = AnnParens noAnn noAnn
    1035 1045
    ... ... @@ -1136,3 +1146,7 @@ instance Outputable AnnAnnDecl where
    1136 1146 
     instance Outputable AnnPragSCC where
    1137 1147 
       ppr (AnnPragSCC o c l)
    1138 1148 
         = text "AnnPragSCC" <+> ppr o <+> ppr c <+> ppr l
    1149 
    +
    1150 
    +instance Outputable AnnPragNoCover where
    1151 
    +  ppr (AnnPragNoCover o c l)
    1152 
    +    = text "AnnPragNoCover" <+> ppr o <+> ppr c <+> ppr l

  • compiler/GHC/Parser/Lexer.x
    ... ... @@ -852,6 +852,7 @@ data Token
    852 852 
       | ITline_prag         SourceText  -- not usually produced, see 'UsePosPragsBit'
    853 853 
       | ITcolumn_prag       SourceText  -- not usually produced, see 'UsePosPragsBit'
    854 854 
       | ITscc_prag          SourceText
    855 
    +  | ITnocover_prag      SourceText
    855 856 
       | ITunpack_prag       SourceText
    856 857 
       | ITnounpack_prag     SourceText
    857 858 
       | ITann_prag          SourceText
    ... ... @@ -3535,6 +3536,7 @@ oneWordPrags = Map.fromList [
    3535 3536 
          ("warning", fstrtoken (\s -> ITwarning_prag (SourceText s))),
    3536 3537 
          ("deprecated", fstrtoken (\s -> ITdeprecated_prag (SourceText s))),
    3537 3538 
          ("scc", fstrtoken (\s -> ITscc_prag (SourceText s))),
    3539 
    +     ("nocover", fstrtoken (\s -> ITnocover_prag (SourceText s))),
    3538 3540 
          ("unpack", fstrtoken (\s -> ITunpack_prag (SourceText s))),
    3539 3541 
          ("nounpack", fstrtoken (\s -> ITnounpack_prag (SourceText s))),
    3540 3542 
          ("ann", fstrtoken (\s -> ITann_prag (SourceText s))),

  • compiler/GHC/Rename/Expr.hs
    ... ... @@ -469,6 +469,7 @@ rnExpr (HsPragE x prag expr)
    469 469 
       where
    470 470 
         rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
    471 471 
         rn_prag (HsPragSCC x ann) = HsPragSCC x $ rnStringLit ann
    472 
    +    rn_prag (HsPragNoCover x ann) = HsPragNoCover x $ rnStringLit ann
    472 473
    473 474 
     rnExpr (HsLam x lam_variant matches)
    474 475 
       = do { (matches', fvs_ms) <- rnMatchGroup (LamAlt lam_variant) rnLExpr matches

  • compiler/GHC/Tc/Gen/App.hs
    ... ... @@ -2445,3 +2445,4 @@ tcTagToEnum tc_fun tc_args res_ty
    2445 2445
    2446 2446 
     tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
    2447 2447 
     tcExprPrag (HsPragSCC x1 ann) = HsPragSCC x1 (tcStringLit ann)
    2448 
    +tcExprPrag (HsPragNoCover x1 ann) = HsPragNoCover x1 (tcStringLit ann)

  • compiler/Language/Haskell/Syntax/Expr.hs
    ... ... @@ -558,7 +558,7 @@ data DotFieldOcc p
    558 558 
     data HsPragE p
    559 559 
       = HsPragSCC   (XSCC p)
    560 560 
                     (StringLiteral p) -- "set cost centre" SCC pragma
    561 
    -
    561 
    +  | HsPragNoCover (XNoCover p) (StringLiteral p)
    562 562 
       | XHsPragE !(XXPragE p)
    563 563
    564 564 
     -- | Located Haskell Tuple Argument

  • compiler/Language/Haskell/Syntax/Extension.hs
    ... ... @@ -544,6 +544,7 @@ type family XXDotFieldOcc x
    544 544 
     -- -------------------------------------
    545 545 
     -- HsPragE type families
    546 546 
     type family XSCC            x
    547 
    +type family XNoCover        x
    547 548 
     type family XXPragE         x
    548 549
    549 550 
     -- -------------------------------------

  • utils/check-exact/ExactPrint.hs
    ... ... @@ -3346,7 +3346,7 @@ notDodgyE anc =
    3346 3346
    3347 3347 
     -- ---------------------------------------------------------------------
    3348 3348 
     instance ExactPrint (HsPragE GhcPs) where
    3349 
    -  getAnnotationEntry HsPragSCC{}  = NoEntryVal
    3349 
    +  getAnnotationEntry _ = NoEntryVal
    3350 3350 
       setAnnotationAnchor a _ _ _ = a
    3351 3351
    3352 3352 
       exact (HsPragSCC (AnnPragSCC o c l1,st) sl) = do
    ... ... @@ -3355,6 +3355,12 @@ instance ExactPrint (HsPragE GhcPs) where
    3355 3355 
         c' <- markEpToken c
    3356 3356 
         return (HsPragSCC (AnnPragSCC o' c' l1',st) sl)
    3357 3357
    3358 
    +  exact (HsPragNoCover (AnnPragNoCover o c l1,st) sl) = do
    3359 
    +    o' <- markAnnOpen'' o st  "{-# NOCOVER"
    3360 
    +    l1' <- printStringAtAA l1 (sourceTextToString (stringLitSourceText sl) (unpackHText $ sl_fs sl))
    3361 
    +    c' <- markEpToken c
    3362 
    +    return (HsPragSCC (AnnPragSCC o' c' l1',st) sl)
    3363 
    +
    3358 3364 
     instance ExactPrint (HsTypedSplice GhcPs) where
    3359 3365 
       getAnnotationEntry _ = NoEntryVal
    3360 3366

  • utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
    ... ... @@ -251,6 +251,7 @@ classify tok =
    251 251 
         ITline_prag{} -> TkPragma
    252 252 
         ITcolumn_prag{} -> TkPragma
    253 253 
         ITscc_prag{} -> TkPragma
    254 
    +    ITnocover_prag{} -> TkPragma
    254 255 
         ITunpack_prag{} -> TkPragma
    255 256 
         ITnounpack_prag{} -> TkPragma
    256 257 
         ITann_prag{} -> TkPragma
    ... ... @@ -392,6 +393,7 @@ inPragma False tok =
    392 393 
         ITline_prag{} -> True
    393 394 
         ITcolumn_prag{} -> True
    394 395 
         ITscc_prag{} -> True
    396 
    +    ITnocover_prag{} -> True
    395 397 
         ITunpack_prag{} -> True
    396 398 
         ITnounpack_prag{} -> True
    397 399 
         ITann_prag{} -> True

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/dad22d337db971252f34814c3a2208bd812bf5fe...92c7351ce5d5e1a428eed55fe4eadcfcd17c3ab1 at 1790806765