Ben Gamari pushed to branch wip/bump-win32-tarballs at Glasgow Haskell Compiler / GHC

Commits:

10 changed files:

Changes:

  • compiler/GHC/HsToCore/Ticks.hs
    1 
    -{-# LANGUAGE DeriveFunctor            #-}
    2 1 
     {-# LANGUAGE NondecreasingIndentation #-}
    3 
    -{-# LANGUAGE TypeFamilies             #-}
    4 2
    5 3 
     {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
    6 4
    7 5 
     {-
    8 6 
     (c) Galois, 2006
    9 7 
     (c) University of Glasgow, 2007
    8 
    +(c) Florian Ragwitz, 2025
    10 9 
     -}
    11 10
    12 11 
     module GHC.HsToCore.Ticks
    ... ... @@ -38,7 +37,9 @@ import GHC.Utils.Logger
    38 37 
     import GHC.Types.SrcLoc
    39 38 
     import GHC.Types.Basic
    40 39 
     import GHC.Types.Id
    40 
    +import GHC.Types.Id.Info
    41 41 
     import GHC.Types.Var.Set
    42 
    +import GHC.Types.Var.Env
    42 43 
     import GHC.Types.Name.Set hiding (FreeVars)
    43 44 
     import GHC.Types.Name
    44 45 
     import GHC.Types.CostCentre
    ... ... @@ -48,6 +49,7 @@ import GHC.Types.ProfAuto
    48 49
    49 50 
     import Control.Monad
    50 51 
     import Data.List (isSuffixOf, intersperse)
    52 
    +import Data.Foldable (toList)
    51 53
    52 54 
     import Trace.Hpc.Mix
    53 55
    ... ... @@ -123,6 +125,7 @@ addTicksToBinds logger cfg
    123 125 
                           , density      = mkDensity tickish $ ticks_profAuto cfg
    124 126 
                           , this_mod     = mod
    125 127 
                           , tickishType  = tickish
    128 
    +                      , recSelBinds  = emptyVarEnv
    126 129 
                           }
    127 130 
                     (binds',_,st') = unTM (addTickLHsBinds binds) env st
    128 131 
                 in (binds', st')
    ... ... @@ -224,8 +227,7 @@ addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
    224 227 
     addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds
    225 228 
                                                      , abs_exports = abs_exports
    226 229 
                                                      }))) =
    227 
    -  withEnv add_exports $
    228 
    -    withEnv add_inlines $ do
    230 
    +  withEnv (add_rec_sels . add_inlines . add_exports) $ do
    229 231 
           binds' <- addTickLHsBinds binds
    230 232 
           return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }
    231 233 
       where
    ... ... @@ -247,6 +249,12 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds
    247 249 
                           | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
    248 250 
                           , isInlinePragma (idInlinePragma pid) ] }
    249 251
    252 
    +   add_rec_sels env =
    253 
    +     env{ recSelBinds = recSelBinds env `extendVarEnvList`
    254 
    +                          [ (abe_mono, abe_poly)
    255 
    +                          | ABE{ abe_poly, abe_mono } <- abs_exports
    256 
    +                          , RecSelId{} <- [idDetails abe_poly] ] }
    257 
    +
    250 258 
     addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do
    251 259 
       let name = getOccString id
    252 260 
       decl_path <- getPathEntry
    ... ... @@ -261,6 +269,10 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches
    261 269 
       tickish <- tickishType `liftM` getEnv
    262 270 
       case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do
    263 271
    272 
    +  -- See Note [Record-selector ticks]
    273 
    +  selTick <- recSelTick id
    274 
    +  case selTick of { Just tick -> tick_rec_sel tick; _ -> do
    275 
    +
    264 276 
       (fvs, mg) <-
    265 277 
             getFreeVars $
    266 278 
             addPathEntry name $
    ... ... @@ -288,7 +300,40 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches
    288 300 
       let mbCons = maybe Prelude.id (:)
    289 301 
       return $ L pos $ funBind { fun_matches = mg
    290 302 
                                , fun_ext = second (tick `mbCons`) (fun_ext funBind) }
    291 
    -  }
    303 
    +  } }
    304 
    +  where
    305 
    +    -- See Note [Record-selector ticks]
    306 
    +    tick_rec_sel tick =
    307 
    +      pure $ L pos $ funBind { fun_ext = second (tick :) (fun_ext funBind) }
    308 
    +
    309 
    +
    310 
    +-- Note [Record-selector ticks]
    311 
    +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    312 
    +-- Users expect (see #17834) that accessing a record field by its name using
    313 
    +-- NamedFieldPuns or RecordWildCards will mark it as covered. This is very
    314 
    +-- reasonable, because otherwise the use of those two language features will
    315 
    +-- produce unnecessary noise in coverage reports, distracting from real
    316 
    +-- coverage problems.
    317 
    +--
    318 
    +-- Because of that, GHC chooses to treat record selectors specially for
    319 
    +-- coverage purposes to improve the developer experience.
    320 
    +--
    321 
    +-- This is done by keeping track of which 'Id's are effectively bound to
    322 
    +-- record fields (using NamedFieldPuns or RecordWildCards) in 'TickTransEnv's
    323 
    +-- 'recSelBinds', and making 'HsVar's corresponding to those fields tick the
    324 
    +-- appropriate box when executed.
    325 
    +--
    326 
    +-- To enable that, we also treat 'FunBind's for record selector functions
    327 
    +-- specially. We only create a TopLevelBox for the record selector function,
    328 
    +-- skipping the ExpBox that'd normally be created. This simplifies the re-use
    329 
    +-- of ticks for the same record selector, and is done by not recursing into
    330 
    +-- the fun_matches match group for record selector functions.
    331 
    +--
    332 
    +-- This scheme could be extended further in the future, making coverage for
    333 
    +-- constructor fields (named or even positional) mean that the field was
    334 
    +-- accessed at run-time. For the time being, we only cover NamedFieldPuns and
    335 
    +-- RecordWildCards binds to cover most practical use-cases while keeping it
    336 
    +-- simple.
    292 337
    293 338 
     -- TODO: Revisit this
    294 339 
     addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
    ... ... @@ -471,7 +516,10 @@ addBinTickLHsExpr boxLabel e@(L pos e0)
    471 516 
     -- in the addTickLHsExpr family of functions.)
    472 517
    473 518 
     addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
    474 
    -addTickHsExpr e@(HsVar _ (L _ id))  = do freeVar id; return e
    519 
    +-- See Note [Record-selector ticks]
    520 
    +addTickHsExpr e@(HsVar _ (L _ id)) =
    521 
    +    freeVar id >> recSelTick id >>= pure . maybe e wrap
    522 
    +  where wrap tick = XExpr . HsTick tick . noLocA $ e
    475 523 
     addTickHsExpr e@(HsIPVar {})            = return e
    476 524 
     addTickHsExpr e@(HsOverLit {})          = return e
    477 525 
     addTickHsExpr e@(HsOverLabel{})         = return e
    ... ... @@ -532,7 +580,7 @@ addTickHsExpr (HsMultiIf ty alts)
    532 580 
            ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts
    533 581 
            ; return $ HsMultiIf ty alts' }
    534 582 
     addTickHsExpr (HsLet x binds e) =
    535 
    -        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do
    583 
    +        bindLocals binds $ do
    536 584 
               binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
    537 585 
               e' <- addTickLHsExprLetBody e
    538 586 
               return (HsLet x binds' e')
    ... ... @@ -580,6 +628,7 @@ addTickHsExpr e@(HsUntypedSplice{}) = return e
    580 628 
     addTickHsExpr e@(HsGetField {})      = return e
    581 629 
     addTickHsExpr e@(HsProjection {})    = return e
    582 630 
     addTickHsExpr (HsProc x pat cmdtop) =
    631 
    +      bindLocals pat $
    583 632 
             liftM2 (HsProc x)
    584 633 
                     (addTickLPat pat)
    585 634 
                     (traverse (addTickHsCmdTop) cmdtop)
    ... ... @@ -646,19 +695,17 @@ addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} -> Match GhcTc (L
    646 695 
                  -> TM (Match GhcTc (LHsExpr GhcTc))
    647 696 
     addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = L _ pats
    648 697 
                                                            , m_grhss = gRHSs }) =
    649 
    -  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
    698 
    +  bindLocals pats $ do
    650 699 
         gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs
    651 700 
         return $ match { m_grhss = gRHSs' }
    652 701
    653 702 
     addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
    654 703 
                  -> TM (GRHSs GhcTc (LHsExpr GhcTc))
    655 704 
     addTickGRHSs isOneOfMany isLambda isDoExp (GRHSs x guarded local_binds) =
    656 
    -  bindLocals binders $ do
    705 
    +  bindLocals local_binds $ do
    657 706 
         local_binds' <- addTickHsLocalBinds local_binds
    658 707 
         guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp)) guarded
    659 708 
         return $ GRHSs x guarded' local_binds'
    660 
    -  where
    661 
    -    binders = collectLocalBinders CollNoDictBinders local_binds
    662 709
    663 710 
     addTickGRHS :: Bool -> Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
    664 711 
                 -> TM (GRHS GhcTc (LHsExpr GhcTc))
    ... ... @@ -697,7 +744,7 @@ addTickLStmts isGuard stmts = do
    697 744 
     addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
    698 745 
                    -> TM ([ExprLStmt GhcTc], a)
    699 746 
     addTickLStmts' isGuard lstmts res
    700 
    -  = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $
    747 
    +  = bindLocals lstmts $
    701 748 
         do { lstmts' <- mapM (traverse (addTickStmt isGuard)) lstmts
    702 749 
            ; a <- res
    703 750 
            ; return (lstmts', a) }
    ... ... @@ -710,6 +757,7 @@ addTickStmt _isGuard (LastStmt x e noret ret) =
    710 757 
                     (pure noret)
    711 758 
                     (addTickSyntaxExpr hpcSrcSpan ret)
    712 759 
     addTickStmt _isGuard (BindStmt xbs pat e) =
    760 
    +      bindLocals pat $
    713 761 
             liftM4 (\b f -> BindStmt $ XBindStmtTc
    714 762 
                         { xbstc_bindOp = b
    715 763 
                         , xbstc_boundResultType = xbstc_boundResultType xbs
    ... ... @@ -770,17 +818,19 @@ addTickApplicativeArg isGuard (op, arg) =
    770 818 
       liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
    771 819 
      where
    772 820 
       addTickArg (ApplicativeArgOne m_fail pat expr isBody) =
    773 
    -    ApplicativeArgOne
    774 
    -      <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
    775 
    -      <*> addTickLPat pat
    776 
    -      <*> addTickLHsExpr expr
    777 
    -      <*> pure isBody
    821 
    +    bindLocals pat $
    822 
    +      ApplicativeArgOne
    823 
    +        <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
    824 
    +        <*> addTickLPat pat
    825 
    +        <*> addTickLHsExpr expr
    826 
    +        <*> pure isBody
    778 827 
       addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =
    779 
    -    (ApplicativeArgMany x)
    780 
    -      <$> addTickLStmts isGuard stmts
    781 
    -      <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))
    782 
    -      <*> addTickLPat pat
    783 
    -      <*> pure ctxt
    828 
    +    bindLocals pat $
    829 
    +      ApplicativeArgMany x
    830 
    +        <$> addTickLStmts isGuard stmts
    831 
    +        <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))
    832 
    +        <*> addTickLPat pat
    833 
    +        <*> pure ctxt
    784 834
    785 835 
     addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
    786 836 
                           -> TM (ParStmtBlock GhcTc GhcTc)
    ... ... @@ -871,7 +921,7 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
    871 921 
                     (addTickLHsCmd c2)
    872 922 
                     (addTickLHsCmd c3)
    873 923 
     addTickHsCmd (HsCmdLet x binds c) =
    874 
    -        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do
    924 
    +        bindLocals binds $ do
    875 925 
               binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
    876 926 
               c' <- addTickLHsCmd c
    877 927 
               return (HsCmdLet x binds' c')
    ... ... @@ -907,18 +957,16 @@ addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
    907 957
    908 958 
     addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
    909 959 
     addTickCmdMatch match@(Match { m_pats = L _ pats, m_grhss = gRHSs }) =
    910 
    -  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
    960 
    +  bindLocals pats $ do
    911 961 
         gRHSs' <- addTickCmdGRHSs gRHSs
    912 962 
         return $ match { m_grhss = gRHSs' }
    913 963
    914 964 
     addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
    915 965 
     addTickCmdGRHSs (GRHSs x guarded local_binds) =
    916 
    -  bindLocals binders $ do
    966 
    +  bindLocals local_binds $ do
    917 967 
         local_binds' <- addTickHsLocalBinds local_binds
    918 968 
         guarded' <- mapM (traverse addTickCmdGRHS) guarded
    919 969 
         return $ GRHSs x guarded' local_binds'
    920 
    -  where
    921 
    -    binders = collectLocalBinders CollNoDictBinders local_binds
    922 970
    923 971 
     addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
    924 972 
     -- The *guards* are *not* Cmds, although the body is
    ... ... @@ -937,15 +985,14 @@ addTickLCmdStmts stmts = do
    937 985 
     addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
    938 986 
                       -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
    939 987 
     addTickLCmdStmts' lstmts res
    940 
    -  = bindLocals binders $ do
    988 
    +  = bindLocals lstmts $ do
    941 989 
             lstmts' <- mapM (traverse addTickCmdStmt) lstmts
    942 990 
             a <- res
    943 991 
             return (lstmts', a)
    944 
    -  where
    945 
    -        binders = collectLStmtsBinders CollNoDictBinders lstmts
    946 992
    947 993 
     addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
    948 994 
     addTickCmdStmt (BindStmt x pat c) =
    995 
    +      bindLocals pat $
    949 996 
             liftM2 (BindStmt x)
    950 997 
                     (addTickLPat pat)
    951 998 
                     (addTickLHsCmd c)
    ... ... @@ -1006,11 +1053,13 @@ addTickArithSeqInfo (FromThenTo e1 e2 e3) =
    1006 1053
    1007 1054 
     data TickTransState = TT { ticks       :: !(SizedSeq Tick)
    1008 1055 
                              , ccIndices   :: !CostCentreState
    1056 
    +                         , recSelTicks :: !(IdEnv CoreTickish)
    1009 1057 
                              }
    1010 1058
    1011 1059 
     initTTState :: TickTransState
    1012 1060 
     initTTState = TT { ticks        = emptySS
    1013 1061 
                      , ccIndices    = newCostCentreState
    1062 
    +                 , recSelTicks  = emptyVarEnv
    1014 1063 
                      }
    1015 1064
    1016 1065 
     addMixEntry :: Tick -> TM Int
    ... ... @@ -1021,6 +1070,10 @@ addMixEntry ent = do
    1021 1070 
            }
    1022 1071 
       return c
    1023 1072
    1073 
    +addRecSelTick :: Id -> CoreTickish -> TM ()
    1074 
    +addRecSelTick sel tick =
    1075 
    +  setState $ \s -> s{ recSelTicks = extendVarEnv (recSelTicks s) sel tick }
    1076 
    +
    1024 1077 
     data TickTransEnv = TTE { fileName     :: FastString
    1025 1078 
                             , density      :: TickDensity
    1026 1079 
                             , tte_countEntries :: !Bool
    ... ... @@ -1033,6 +1086,7 @@ data TickTransEnv = TTE { fileName :: FastString
    1033 1086 
                             , blackList    :: Set RealSrcSpan
    1034 1087 
                             , this_mod     :: Module
    1035 1088 
                             , tickishType  :: TickishType
    1089 
    +                        , recSelBinds  :: IdEnv Id
    1036 1090 
                             }
    1037 1091
    1038 1092 
     --      deriving Show
    ... ... @@ -1154,12 +1208,13 @@ ifGoodTickSrcSpan pos then_code else_code = do
    1154 1208 
       good <- isGoodTickSrcSpan pos
    1155 1209 
       if good then then_code else else_code
    1156 1210
    1157 
    -bindLocals :: [Id] -> TM a -> TM a
    1158 
    -bindLocals new_ids (TM m)
    1159 
    -  = TM $ \ env st ->
    1160 
    -                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
    1161 
    -                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
    1162 
    -  where occs = [ nameOccName (idName id) | id <- new_ids ]
    1211 
    +bindLocals :: (CollectBinders bndr, CollectFldBinders bndr) => bndr -> TM a -> TM a
    1212 
    +bindLocals from (TM m) = TM $ \env st ->
    1213 
    +  case m (with_bnds env) st of
    1214 
    +    (r, fv, st') -> (r, fv `delListFromOccEnv` (map (nameOccName . idName) new_bnds), st')
    1215 
    +  where with_bnds e = e{ inScope = inScope e `extendVarSetList` new_bnds
    1216 
    +                       , recSelBinds = recSelBinds e `plusVarEnv` collectFldBinds from }
    1217 
    +        new_bnds = collectBinds from
    1163 1218
    1164 1219 
     withBlackListed :: SrcSpan -> TM a -> TM a
    1165 1220 
     withBlackListed (RealSrcSpan ss _) = withEnv (\ env -> env { blackList = Set.insert ss (blackList env) })
    ... ... @@ -1186,6 +1241,17 @@ allocTickBox boxLabel countEntries topOnly pos m
    1186 1241 
           tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
    1187 1242 
           return (this_loc (XExpr $ HsTick tickish $ this_loc e))
    1188 1243
    1244 
    +recSelTick :: Id -> TM (Maybe CoreTickish)
    1245 
    +recSelTick id = ifDensity TickForCoverage maybe_tick (pure Nothing)
    1246 
    +  where
    1247 
    +    maybe_tick = getEnv >>=
    1248 
    +      maybe (pure Nothing) tick . (`lookupVarEnv` id) . recSelBinds
    1249 
    +    tick sel = getState >>=
    1250 
    +      maybe (alloc sel) (pure . Just) . (`lookupVarEnv` sel) . recSelTicks
    1251 
    +    alloc sel = allocATickBox (box sel) False False (getSrcSpan sel) noFVs
    1252 
    +                  >>= traverse (\t -> t <$ addRecSelTick sel t)
    1253 
    +    box sel = TopLevelBox [getOccString sel]
    1254 
    +
    1189 1255 
     -- the tick application inherits the source position of its
    1190 1256 
     -- expression argument to support nested box allocations
    1191 1257 
     allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
    ... ... @@ -1288,3 +1354,98 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
    1288 1354 
             matchCount :: LMatch GhcTc body -> Int
    1289 1355 
             matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))
    1290 1356 
               = length grhss
    1357 
    +
    1358 
    +-- | Convenience class used by 'bindLocals' to collect new bindings from
    1359 
    +-- various parts of he AST. Just delegates to
    1360 
    +-- 'collect{Pat,Pats,Local,LStmts}Binders' from 'GHC.Hs.Utils' as appropriate.
    1361 
    +class CollectBinders a where
    1362 
    +  collectBinds :: a -> [Id]
    1363 
    +
    1364 
    +-- | Variant of 'CollectBinders' which collects information on which locals
    1365 
    +-- are bound to record fields (currently only via 'RecordWildCards' or
    1366 
    +-- 'NamedFieldPuns') to enable better coverage support for record selectors.
    1367 
    +--
    1368 
    +-- See Note [Record-selector ticks].
    1369 
    +class CollectFldBinders a where
    1370 
    +  collectFldBinds :: a -> IdEnv Id
    1371 
    +
    1372 
    +instance CollectBinders (LocatedA (Pat GhcTc)) where
    1373 
    +  collectBinds = collectPatBinders CollNoDictBinders
    1374 
    +instance CollectBinders [LocatedA (Pat GhcTc)] where
    1375 
    +  collectBinds = collectPatsBinders CollNoDictBinders
    1376 
    +instance CollectBinders (HsLocalBinds GhcTc) where
    1377 
    +  collectBinds = collectLocalBinders CollNoDictBinders
    1378 
    +instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsExpr GhcTc)))] where
    1379 
    +  collectBinds = collectLStmtsBinders CollNoDictBinders
    1380 
    +instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsCmd GhcTc)))] where
    1381 
    +  collectBinds = collectLStmtsBinders CollNoDictBinders
    1382 
    +
    1383 
    +instance (CollectFldBinders a) => CollectFldBinders [a] where
    1384 
    +  collectFldBinds = foldr (flip plusVarEnv . collectFldBinds) emptyVarEnv
    1385 
    +instance (CollectFldBinders e) => CollectFldBinders (GenLocated l e) where
    1386 
    +  collectFldBinds = collectFldBinds . unLoc
    1387 
    +instance CollectFldBinders (Pat GhcTc) where
    1388 
    +  collectFldBinds ConPat{ pat_args = RecCon HsRecFields{ rec_flds, rec_dotdot } } =
    1389 
    +    collectFldBinds rec_flds `plusVarEnv` plusVarEnvList (zipWith fld_bnds [0..] rec_flds)
    1390 
    +    where n_explicit | Just (L _ (RecFieldsDotDot n)) <- rec_dotdot = n
    1391 
    +                     | otherwise = length rec_flds
    1392 
    +          fld_bnds n (L _ HsFieldBind{ hfbLHS = L _ FieldOcc{ foLabel = L _ sel }
    1393 
    +                                     , hfbRHS = L _ (VarPat _ (L _ var))
    1394 
    +                                     , hfbPun })
    1395 
    +            | hfbPun || n >= n_explicit = unitVarEnv var sel
    1396 
    +          fld_bnds _ _ = emptyVarEnv
    1397 
    +  collectFldBinds ConPat{ pat_args = PrefixCon pats } = collectFldBinds pats
    1398 
    +  collectFldBinds ConPat{ pat_args = InfixCon p1 p2 } = collectFldBinds [p1, p2]
    1399 
    +  collectFldBinds (LazyPat _ pat) = collectFldBinds pat
    1400 
    +  collectFldBinds (BangPat _ pat) = collectFldBinds pat
    1401 
    +  collectFldBinds (AsPat _ _ pat) = collectFldBinds pat
    1402 
    +  collectFldBinds (ViewPat _ _ pat) = collectFldBinds pat
    1403 
    +  collectFldBinds (ParPat _ pat) = collectFldBinds pat
    1404 
    +  collectFldBinds (ListPat _ pats) = collectFldBinds pats
    1405 
    +  collectFldBinds (TuplePat _ pats _) = collectFldBinds pats
    1406 
    +  collectFldBinds (SumPat _ pats _ _) = collectFldBinds pats
    1407 
    +  collectFldBinds (SigPat _ pat _) = collectFldBinds pat
    1408 
    +  collectFldBinds (XPat exp) = collectFldBinds exp
    1409 
    +  collectFldBinds VarPat{} = emptyVarEnv
    1410 
    +  collectFldBinds WildPat{} = emptyVarEnv
    1411 
    +  collectFldBinds OrPat{} = emptyVarEnv
    1412 
    +  collectFldBinds LitPat{} = emptyVarEnv
    1413 
    +  collectFldBinds NPat{} = emptyVarEnv
    1414 
    +  collectFldBinds NPlusKPat{} = emptyVarEnv
    1415 
    +  collectFldBinds SplicePat{} = emptyVarEnv
    1416 
    +  collectFldBinds EmbTyPat{} = emptyVarEnv
    1417 
    +  collectFldBinds InvisPat{} = emptyVarEnv
    1418 
    +instance (CollectFldBinders r) => CollectFldBinders (HsFieldBind l r) where
    1419 
    +  collectFldBinds = collectFldBinds . hfbRHS
    1420 
    +instance CollectFldBinders XXPatGhcTc where
    1421 
    +  collectFldBinds (CoPat _ pat _) = collectFldBinds pat
    1422 
    +  collectFldBinds (ExpansionPat _ pat) = collectFldBinds pat
    1423 
    +instance CollectFldBinders (HsLocalBinds GhcTc) where
    1424 
    +  collectFldBinds (HsValBinds _ bnds) = collectFldBinds bnds
    1425 
    +  collectFldBinds HsIPBinds{} = emptyVarEnv
    1426 
    +  collectFldBinds EmptyLocalBinds{} = emptyVarEnv
    1427 
    +instance CollectFldBinders (HsValBinds GhcTc) where
    1428 
    +  collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds
    1429 
    +  collectFldBinds (XValBindsLR (NValBinds bnds _)) = collectFldBinds (map snd bnds)
    1430 
    +instance CollectFldBinders (HsBind GhcTc) where
    1431 
    +  collectFldBinds PatBind{ pat_lhs } = collectFldBinds pat_lhs
    1432 
    +  collectFldBinds (XHsBindsLR AbsBinds{ abs_exports, abs_binds }) =
    1433 
    +    mkVarEnv [ (abe_poly, sel)
    1434 
    +             | ABE{ abe_poly, abe_mono } <- abs_exports
    1435 
    +             , Just sel <- [lookupVarEnv monos abe_mono] ]
    1436 
    +    where monos = collectFldBinds abs_binds
    1437 
    +  collectFldBinds VarBind{} = emptyVarEnv
    1438 
    +  collectFldBinds FunBind{} = emptyVarEnv
    1439 
    +  collectFldBinds PatSynBind{} = emptyVarEnv
    1440 
    +instance CollectFldBinders (Stmt GhcTc e) where
    1441 
    +  collectFldBinds (BindStmt _ pat _) = collectFldBinds pat
    1442 
    +  collectFldBinds (LetStmt _ bnds) = collectFldBinds bnds
    1443 
    +  collectFldBinds (ParStmt _ xs _ _) = collectFldBinds [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss]
    1444 
    +  collectFldBinds TransStmt{ trS_stmts } = collectFldBinds trS_stmts
    1445 
    +  collectFldBinds RecStmt{ recS_stmts } = collectFldBinds recS_stmts
    1446 
    +  collectFldBinds (XStmtLR (ApplicativeStmt _ args _)) = collectFldBinds (map snd args)
    1447 
    +  collectFldBinds LastStmt{} = emptyVarEnv
    1448 
    +  collectFldBinds BodyStmt{} = emptyVarEnv
    1449 
    +instance CollectFldBinders (ApplicativeArg GhcTc) where
    1450 
    +  collectFldBinds ApplicativeArgOne{ app_arg_pattern } = collectFldBinds app_arg_pattern
    1451 
    +  collectFldBinds ApplicativeArgMany{ bv_pattern } = collectFldBinds bv_pattern

  • docs/users_guide/9.14.1-notes.rst
    ... ... @@ -138,6 +138,11 @@ Compiler
    138 138 
       uses of the now deprecated ``pattern`` namespace specifier in import/export
    139 139 
       lists. See `GHC Proposal #581, section 2.3 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0581-namespace-specified-imports.rst#deprecate-use-of-pattern-in-import-export-lists>`_.
    140 140
    141 
    +- Code coverage (:ghc-flag:`-fhpc`) now treats uses of record fields via
    142 
    +  :extension:`RecordWildCards` or :extension:`NamedFieldPuns` as if the fields
    143 
    +  were accessed using the generated record selector functions, marking the fields
    144 
    +  as covered in coverage reports (:ghc-ticket:`17834`).
    145 
    +
    141 146 
     GHCi
    142 147 
     ~~~~
    143 148

  • mk/get-win32-tarballs.py
    ... ... @@ -8,7 +8,7 @@ import argparse
    8 8 
     import sys
    9 9 
     from sys import stderr
    10 10
    11 
    -TARBALL_VERSION = '0.8'
    11 
    +TARBALL_VERSION = '0.9'
    12 12 
     BASE_URL = "https://downloads.haskell.org/ghc/mingw/{}".format(TARBALL_VERSION)
    13 13 
     DEST = Path('ghc-tarballs/mingw-w64')
    14 14 
     ARCHS = ['x86_64', 'sources']

  • rts/linker/LoadArchive.c
    ... ... @@ -223,21 +223,22 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_,
    223 223 
         char* gnuFileIndex, pathchar* path, size_t* thisFileNameSize,
    224 224 
         size_t* fileNameSize)
    225 225 
     {
    226 
    -    int n;
    227 226 
         char *fileName = *fileName_;
    228 227 
         if (isdigit(fileName[1])) {
    229 
    -        int i;
    230 
    -        for (n = 2; isdigit(fileName[n]); n++)
    231 
    -            ;
    232 
    -
    233 
    -        fileName[n] = '\0';
    234 
    -        n = atoi(fileName + 1);
    235 228 
             if (gnuFileIndex == NULL) {
    236 229 
                 errorBelch("loadArchive: GNU-variant filename "
    237 230 
                         "without an index while reading from `%" PATH_FMT "'",
    238 231 
                         path);
    239 232 
                 return false;
    240 233 
             }
    234 
    +
    235 
    +        int n;
    236 
    +        for (n = 2; isdigit(fileName[n]); n++)
    237 
    +            ;
    238 
    +
    239 
    +        char *end;
    240 
    +        fileName[n] = '\0';
    241 
    +        n = strtol(fileName + 1, &end, 10);
    241 242 
             if (n < 0 || n > gnuFileIndexSize) {
    242 243 
                 errorBelch("loadArchive: GNU-variant filename "
    243 244 
                         "offset %d out of range [0..%d] "
    ... ... @@ -245,17 +246,27 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_,
    245 246 
                         n, gnuFileIndexSize, path);
    246 247 
                 return false;
    247 248 
             }
    248 
    -        if (n != 0 && gnuFileIndex[n - 1] != '\n') {
    249 
    +
    250 
    +        // Check that the previous entry ends with the expected
    251 
    +        // end-of-string delimiter.
    252 
    +#if defined(mingw32_HOST_OS)
    253 
    +#define IS_SYMBOL_DELIMITER(STR) (STR =='\n' || STR == '\0')
    254 
    +#else
    255 
    +#define IS_SYMBOL_DELIMITER(STR) (STR =='\n')
    256 
    +#endif
    257 
    +        if (n != 0 && !IS_SYMBOL_DELIMITER(gnuFileIndex[n - 1])) {
    249 258 
                 errorBelch("loadArchive: GNU-variant filename offset "
    250 259 
                         "%d invalid (range [0..%d]) while reading "
    251 260 
                         "filename from `%" PATH_FMT "'",
    252 261 
                         n, gnuFileIndexSize, path);
    253 262 
                 return false;
    254 263 
             }
    255 
    -        for (i = n; gnuFileIndex[i] != '\n'; i++)
    264 
    +
    265 
    +        int i;
    266 
    +        for (i = n; !IS_SYMBOL_DELIMITER(gnuFileIndex[i]); i++)
    256 267 
                 ;
    257 268
    258 
    -        size_t FileNameSize = i - n - 1;
    269 
    +        size_t FileNameSize = i - n;
    259 270 
             if (FileNameSize >= *fileNameSize) {
    260 271 
                 /* Double it to avoid potentially continually
    261 272 
                  increasing it by 1 */

  • rts/linker/PEi386.c
    ... ... @@ -342,6 +342,98 @@
    342 342 
        Finally, we enter `ocResolve`, where we resolve relocations and and allocate
    343 343 
        jump islands (using the m32 allocator for backing storage) as necessary.
    344 344
    345 
    +   Note [Windows API Set]
    346 
    +   ~~~~~~~~~~~~~~~~~~~~~~
    347 
    +   Windows has a concept called API Sets [1][2] which is intended to be Windows's
    348 
    +   equivalent to glibc's symbolic versioning.  It is also used to handle the API
    349 
    +   surface difference between different device classes.  e.g. the API might be
    350 
    +   handled differently between a desktop and tablet.
    351 
    +
    352 
    +   This is handled through two mechanisms:
    353 
    +
    354 
    +   1. Direct Forward:  These use import libraries to manage to first level
    355 
    +      redirection.  So what used to be in ucrt.dll is now redirected based on
    356 
    +      ucrt.lib.  Every API now points to a possible different set of API sets
    357 
    +      each following the API set contract:
    358 
    +
    359 
    +      * The name must begin either with the string api- or ext-.
    360 
    +      * Names that begin with api- represent APIs that exist on all Windows
    361 
    +        editions that satisfy the API's version requirements.
    362 
    +      * Names that begin with ext- represent APIs that may not exist on all
    363 
    +        Windows editions.
    364 
    +      * The name must end with the sequence l<n>-<n>-<n>, where n consists of
    365 
    +        decimal digits.
    366 
    +      * The body of the name can be alphanumeric characters, or dashes (-).
    367 
    +      * The name is case insensitive.
    368 
    +
    369 
    +      Here are some examples of API set contract names:
    370 
    +
    371 
    +        - api-ms-win-core-ums-l1-1-0
    372 
    +        - ext-ms-win-com-ole32-l1-1-5
    373 
    +        - ext-ms-win-ntuser-window-l1-1-0
    374 
    +        - ext-ms-win-ntuser-window-l1-1-1
    375 
    +
    376 
    +      Forward references don't require anything special from the calling
    377 
    +      application in that the Windows loader through "LoadLibrary" will
    378 
    +      automatically load the right reference for you if given an API set
    379 
    +      name including the ".dll" suffix.  For example:
    380 
    +
    381 
    +      INFO: DLL api-ms-win-eventing-provider-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    382 
    +      INFO: DLL api-ms-win-core-apiquery-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\ntdll.dll by API set
    383 
    +      INFO: DLL api-ms-win-core-processthreads-l1-1-3.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    384 
    +      INFO: DLL api-ms-win-core-processthreads-l1-1-2.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    385 
    +      INFO: DLL api-ms-win-core-processthreads-l1-1-1.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    386 
    +      INFO: DLL api-ms-win-core-processthreads-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    387 
    +      INFO: DLL api-ms-win-core-registry-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    388 
    +      INFO: DLL api-ms-win-core-heap-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    389 
    +      INFO: DLL api-ms-win-core-heap-l2-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    390 
    +      INFO: DLL api-ms-win-core-memory-l1-1-1.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    391 
    +      INFO: DLL api-ms-win-core-memory-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    392 
    +      INFO: DLL api-ms-win-core-memory-l1-1-2.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    393 
    +      INFO: DLL api-ms-win-core-handle-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set
    394 
    +
    395 
    +      Which shows how the loader has redirected some of the references used
    396 
    +      by ghci.
    397 
    +
    398 
    +      Historically though we've treated shared libs lazily.  We would load\
    399 
    +      the shared library, but not resolve the symbol immediately and wait until
    400 
    +      the symbol is requested to iterate in order through the shared libraries.
    401 
    +
    402 
    +      This assumes that you ever only had one version of a symbol.  i.e. we had
    403 
    +      an assumption that all exported symbols in different shared libraries
    404 
    +      should be the same, because most of the time they come from re-exporting
    405 
    +      from a base library.  This is a bit of a weak assumption and doesn't hold
    406 
    +      with API Sets.
    407 
    +
    408 
    +      For that reason the loader now resolves symbols immediately, and because
    409 
    +      we now resolve using BIND_NOW we must make sure that a symbol loaded
    410 
    +      through an OC has precedent because the BIND_NOW refernce was not asked
    411 
    +      for.   For that reason we load the symbols for API sets with the
    412 
    +      SYM_TYPE_DUP_DISCARD flag set.
    413 
    +
    414 
    +    2. Reverse forwarders:  This is when the application has a direct reference
    415 
    +       to the old name of an API. e.g. if GHC still used "msvcrt.dll" or
    416 
    +       "ucrt.dll" we would have had to deal with this case.  In this case the
    417 
    +       loader intercepts the call and if it exists the dll is loaded.  There is
    418 
    +       an extra indirection as you go from foo.dll => api-ms-foo-1.dll => foo_imp.dll
    419 
    +
    420 
    +       But if the API doesn't exist on the device it's resolved to a stub in the
    421 
    +       API set that if called will result in an error should it be called [3].
    422 
    +
    423 
    +    This means that usages of GetProcAddress and LoadLibrary to check for the
    424 
    +    existance of a function aren't safe, because they'll always succeed, but may
    425 
    +    result in a pointer to the stub rather than the actual function.
    426 
    +
    427 
    +    WHat does this mean for the RTS linker? Nothing.  We don't have a fallback
    428 
    +    for if the function doesn't exist.  The RTS is merely just executing what
    429 
    +    it was told to run.  It's writers of libraries that have to be careful when
    430 
    +    doing dlopen()/LoadLibrary.
    431 
    +
    432 
    +
    433 
    +   [1] https://learn.microsoft.com/en-us/windows/win32/apiindex/windows-apisets
    434 
    +   [2] https://mingwpy.github.io/ucrt.html#api-set-implementation
    435 
    +   [3] https://learn.microsoft.com/en-us/windows/win32/apiindex/detect-api-set-availability
    436 
    +
    345 437 
     */
    346 438
    347 439 
     #include "Rts.h"
    ... ... @@ -882,7 +974,7 @@ addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded )
    882 974 
                         goto error;
    883 975 
                     }
    884 976 
                 } else {
    885 
    -                goto loaded; /* We're done. DLL has been loaded.  */
    977 
    +                goto loaded_ok; /* We're done. DLL has been loaded.  */
    886 978 
                 }
    887 979 
             }
    888 980 
         }
    ... ... @@ -890,7 +982,7 @@ addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded )
    890 982 
         // We failed to load
    891 983 
         goto error;
    892 984
    893 
    -loaded:
    985 
    +loaded_ok:
    894 986 
         addLoadedDll(&loaded_dll_cache, dll_name, instance);
    895 987 
         addDLLHandle(buf, instance);
    896 988 
         if (loaded) {
    ... ... @@ -1055,7 +1147,8 @@ bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f
    1055 1147 
         // We must call `addDLL_PEi386` directly rather than `addDLL` because `addDLL`
    1056 1148 
         // is now a wrapper around `loadNativeObj` which acquires a lock which we
    1057 1149 
         // already have here.
    1058 
    -    const char* result = addDLL_PEi386(dll, NULL);
    1150 
    +    HINSTANCE instance;
    1151 
    +    const char* result = addDLL_PEi386(dll, &instance);
    1059 1152
    1060 1153 
         stgFree(image);
    1061 1154
    ... ... @@ -1069,6 +1162,24 @@ bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f
    1069 1162 
         }
    1070 1163
    1071 1164 
         stgFree(dll);
    1165 
    +
    1166 
    +    // See Note [Windows API Set]
    1167 
    +    // We must immediately tie the symbol to the shared library.  The easiest
    1168 
    +    // way is to load the symbol immediately. We already have all the
    1169 
    +    // information so might as well
    1170 
    +    SymbolAddr* sym = lookupSymbolInDLL_PEi386 (symbol, instance, dll, NULL);
    1171 
    +    ASSERT(sym);
    1172 
    +    // The symbol must have been found, and we can add it to the RTS symbol table
    1173 
    +    IF_DEBUG(linker, debugBelch("checkAndLoadImportLibrary: resolved symbol %s to %p\n", symbol, sym));
    1174 
    +    // Because the symbol has been loaded before we actually need it, if a
    1175 
    +    // stronger reference wants to add a duplicate we should discard this
    1176 
    +    // one to preserve link order.
    1177 
    +    SymType symType = SYM_TYPE_DUP_DISCARD | SYM_TYPE_HIDDEN;
    1178 
    +    symType |= hdr.Type == IMPORT_OBJECT_CODE ? SYM_TYPE_CODE : SYM_TYPE_DATA;
    1179 
    +
    1180 
    +    if (!ghciInsertSymbolTable(dll, symhash, symbol, sym, false, symType, NULL))
    1181 
    +      return false;
    1182 
    +
    1072 1183 
         return true;
    1073 1184 
     }
    1074 1185

  • testsuite/tests/hpc/recsel/Makefile
    1 
    +TOP=../../..
    2 
    +include $(TOP)/mk/boilerplate.mk
    3 
    +include $(TOP)/mk/test.mk

  • testsuite/tests/hpc/recsel/recsel.hs
    1 
    +{-# LANGUAGE RecordWildCards, NamedFieldPuns, Arrows #-}
    2 
    +
    3 
    +import Control.Monad.Identity
    4 
    +import Control.Arrow (runKleisli, arr, returnA)
    5 
    +import Data.Maybe
    6 
    +import Data.List
    7 
    +import Data.Bifunctor
    8 
    +import Trace.Hpc.Mix
    9 
    +import Trace.Hpc.Tix
    10 
    +import Trace.Hpc.Reflect
    11 
    +
    12 
    +data Foo = Foo { fooA, fooB, fooC, fooD, fooE, fooF, fooG, fooH, fooI
    13 
    +               , fooJ, fooK, fooL, fooM, fooN, fooO :: Int }
    14 
    +data Bar = Bar { barFoo :: Foo }
    15 
    +
    16 
    +fAB Foo{..} = fooA + fooB
    17 
    +fC Foo{fooC} = fooC
    18 
    +fD x Foo{..} = fromMaybe 0 $ if x then Just fooD else Nothing
    19 
    +fE Bar{barFoo = Foo{..}} = fooE
    20 
    +fF Foo{fooF = f} = f
    21 
    +fG f = let Foo{..} = f in fooG
    22 
    +fH f = runIdentity $ do
    23 
    +  Foo{..} <- pure f
    24 
    +  return fooH
    25 
    +fI f = runIdentity $ do
    26 
    +  let Foo{..} = f
    27 
    +  return fooI
    28 
    +fJ f = [ fooJ | let Foo{..} = f ] !! 0
    29 
    +fK = runIdentity . runKleisli (proc f -> do
    30 
    +       Foo{..} <- arr id -< f
    31 
    +       returnA -< fooK)
    32 
    +fL = runIdentity . runKleisli (proc f -> do
    33 
    +       let Foo{..} = f;
    34 
    +       returnA -< fooL)
    35 
    +fM f | Foo{..} <- f = fooM
    36 
    +fN f = fooN f
    37 
    +fO = runIdentity . runKleisli (proc Foo{..} -> returnA -< fooO)
    38 
    +
    39 
    +recSel (n, TopLevelBox [s]) | any (`isPrefixOf` s) ["foo", "bar"] = Just (n, s)
    40 
    +recSel _ = Nothing
    41 
    +
    42 
    +main = do
    43 
    +  let foo = Foo 42 23 0 1 2 3 4 5 6 7 0xaffe 9 10 11 12
    44 
    +  mapM_ (print . ($ foo))
    45 
    +        [fAB, fC, fD False, fE . Bar, fF, fG, fH, fI, fJ, fK, fL, fM, fN, fO]
    46 
    +  (Mix _ _ _ _ mixs) <- readMix [".hpc"] (Left "Main")
    47 
    +  let sels = mapMaybe recSel . zip [0..] $ map snd mixs
    48 
    +  (Tix [TixModule "Main" _ _ tix]) <- examineTix
    49 
    +  mapM_ print . sortOn snd $ map (first (tix !!)) sels

  • testsuite/tests/hpc/recsel/recsel.stdout
    1 
    +65
    2 
    +0
    3 
    +0
    4 
    +2
    5 
    +3
    6 
    +4
    7 
    +5
    8 
    +6
    9 
    +7
    10 
    +45054
    11 
    +9
    12 
    +10
    13 
    +11
    14 
    +12
    15 
    +(0,"barFoo")
    16 
    +(1,"fooA")
    17 
    +(1,"fooB")
    18 
    +(1,"fooC")
    19 
    +(0,"fooD")
    20 
    +(1,"fooE")
    21 
    +(0,"fooF")
    22 
    +(1,"fooG")
    23 
    +(1,"fooH")
    24 
    +(1,"fooI")
    25 
    +(1,"fooJ")
    26 
    +(1,"fooK")
    27 
    +(1,"fooL")
    28 
    +(1,"fooM")
    29 
    +(1,"fooN")
    30 
    +(1,"fooO")

  • testsuite/tests/hpc/recsel/test.T
    1 
    +setTestOpts([omit_ghci, when(fast(), skip), js_skip])
    2 
    +
    3 
    +test('recsel',
    4 
    +     [ignore_extension,
    5 
    +      when(arch('wasm32'), fragile(23243))],
    6 
    +     compile_and_run, ['-fhpc'])
    7 
    +

  • testsuite/tests/profiling/should_run/caller-cc/all.T
    ... ... @@ -8,6 +8,7 @@ setTestOpts(only_ways(prof_ways))
    8 8 
     setTestOpts(extra_files(['Main.hs']))
    9 9 
     setTestOpts(extra_run_opts('7'))
    10 10 
     setTestOpts(grep_prof("Main.hs"))
    11 
    +setTestOpts(grep_prof("calling:"))
    11 12
    12 13 
     # N.B. Main.hs is stolen from heapprof001.
    13 14

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help