Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

15 changed files:

Changes:

  • compiler/GHC/Core/TyCon.hs
    ... ... @@ -2709,6 +2709,7 @@ tyConStupidTheta :: TyCon -> [PredType]
    2709 2709 
     tyConStupidTheta tc@(TyCon { tyConDetails = details })
    2710 2710 
       | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid
    2711 2711 
       | PrimTyCon {} <- details                         = []
    2712 
    +  | PromotedDataCon {} <- details                   = []
    2712 2713 
       | otherwise = pprPanic "tyConStupidTheta" (ppr tc)
    2713 2714
    2714 2715 
     -- | Extract the 'TyVar's bound by a vanilla type synonym

  • 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

  • hadrian/src/Oracles/Flag.hs
    ... ... @@ -7,7 +7,6 @@ module Oracles.Flag (
    7 7 
         targetRTSLinkerOnlySupportsSharedLibs,
    8 8 
         targetSupportsThreadedRts,
    9 9 
         targetSupportsSMP,
    10 
    -    ghcWithInterpreter,
    11 10 
         useLibffiForAdjustors,
    12 11 
         arSupportsDashL,
    13 12 
         arSupportsAtFile
    ... ... @@ -146,31 +145,5 @@ targetSupportsSMP = do
    146 145 
          | goodArch             -> return True
    147 146 
          | otherwise            -> return False
    148 147
    149 
    -
    150 
    --- | When cross compiling, enable for stage0 to get ghci
    151 
    --- support. But when not cross compiling, disable for
    152 
    --- stage0, otherwise we introduce extra dependencies
    153 
    --- like haskeline etc, and mixing stageBoot/stage0 libs
    154 
    --- can cause extra trouble (e.g. #25406)
    155 
    ---
    156 
    --- Also checks whether the target supports GHCi.
    157 
    -ghcWithInterpreter :: Stage -> Action Bool
    158 
    -ghcWithInterpreter stage = do
    159 
    -    is_cross <- flag CrossCompiling
    160 
    -    goodOs <- anyTargetOs [ OSMinGW32, OSLinux, OSSolaris2 -- TODO "cygwin32"?,
    161 
    -                          , OSFreeBSD, OSDragonFly, OSNetBSD, OSOpenBSD
    162 
    -                          , OSDarwin, OSKFreeBSD
    163 
    -                          , OSWasi ]
    164 
    -    goodArch <- (||) <$>
    165 
    -                anyTargetArch [ ArchX86, ArchX86_64, ArchPPC
    166 
    -                              , ArchAArch64, ArchS390X
    167 
    -                              , ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2
    168 
    -                              , ArchRISCV64, ArchLoongArch64
    169 
    -                              , ArchWasm32 ]
    170 
    -                              <*> isArmTarget
    171 
    -    -- Maybe this should just be false for cross compilers. But for now
    172 
    -    -- I've kept the old behaviour where it will say yes. (See #25939)
    173 
    -    return $ goodOs && goodArch && (stage >= Stage1 || is_cross)
    174 
    -
    175 148 
     useLibffiForAdjustors :: Action Bool
    176 149 
     useLibffiForAdjustors = queryTargetTarget tgtUseLibffiForAdjustors

  • hadrian/src/Rules/Generate.hs
    ... ... @@ -26,6 +26,7 @@ import Utilities
    26 26 
     import GHC.Toolchain as Toolchain hiding (HsCpp(HsCpp))
    27 27 
     import GHC.Toolchain.Program
    28 28 
     import GHC.Platform.ArchOS
    29 
    +import Settings.Program (ghcWithInterpreter)
    29 30
    30 31 
     -- | Track this file to rebuild generated files whenever it changes.
    31 32 
     trackGenerateHs :: Expr ()

  • hadrian/src/Settings/Builders/Cabal.hs
    ... ... @@ -11,7 +11,7 @@ import Settings.Builders.Common
    11 11 
     import qualified Settings.Builders.Common as S
    12 12 
     import Control.Exception (assert)
    13 13 
     import qualified Data.Set as Set
    14 
    -import Settings.Program (programContext)
    14 
    +import Settings.Program (programContext, ghcWithInterpreter)
    15 15 
     import GHC.Toolchain (ccLinkProgram, tgtCCompilerLink)
    16 16 
     import GHC.Toolchain.Program (prgFlags)
    17 17

  • hadrian/src/Settings/Packages.hs
    ... ... @@ -11,6 +11,7 @@ import Settings.Builders.Common (wayCcArgs)
    11 11 
     import GHC.Toolchain.Target
    12 12 
     import GHC.Platform.ArchOS
    13 13 
     import Data.Version.Extra
    14 
    +import Settings.Program (ghcWithInterpreter)
    14 15
    15 16 
     -- | Package-specific command-line arguments.
    16 17 
     packageArgs :: Args

  • hadrian/src/Settings/Program.hs
    1 1 
     module Settings.Program
    2 2 
       ( programContext
    3 
    +  , ghcWithInterpreter
    3 4 
       ) where
    4 5
    5 6 
     import Base
    6 7 
     import Context
    7 8 
     import Oracles.Flavour
    9 
    +import Oracles.Flag
    8 10 
     import Packages
    9 11
    12 
    +import GHC.Platform.ArchOS
    13 
    +import Settings.Builders.Common (anyTargetOs, anyTargetArch, isArmTarget)
    14 
    +
    10 15 
     -- TODO: there is duplication and inconsistency between this and
    11 16 
     -- Rules.Program.getProgramContexts. There should only be one way to
    12 17 
     -- get a context/contexts for a given stage and package.
    ... ... @@ -24,3 +29,33 @@ programContext stage pkg = do
    24 29
    25 30 
               notStage0 (Stage0 {}) = False
    26 31 
               notStage0 _ = True
    32 
    +
    33 
    +-- | When cross compiling, enable for stage0 to get ghci
    34 
    +-- support. But when not cross compiling, disable for
    35 
    +-- stage0, otherwise we introduce extra dependencies
    36 
    +-- like haskeline etc, and mixing stageBoot/stage0 libs
    37 
    +-- can cause extra trouble (e.g. #25406)
    38 
    +--
    39 
    +-- Also checks whether the target supports GHCi.
    40 
    +ghcWithInterpreter :: Stage -> Action Bool
    41 
    +ghcWithInterpreter stage = do
    42 
    +    is_cross <- flag CrossCompiling
    43 
    +    goodOs <- anyTargetOs [ OSMinGW32, OSLinux, OSSolaris2 -- TODO "cygwin32"?,
    44 
    +                          , OSFreeBSD, OSDragonFly, OSNetBSD, OSOpenBSD
    45 
    +                          , OSDarwin, OSKFreeBSD
    46 
    +                          , OSWasi ]
    47 
    +    goodArch <- (||) <$>
    48 
    +                anyTargetArch [ ArchX86, ArchX86_64, ArchPPC
    49 
    +                              , ArchAArch64, ArchS390X
    50 
    +                              , ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2
    51 
    +                              , ArchRISCV64, ArchLoongArch64
    52 
    +                              , ArchWasm32 ]
    53 
    +                              <*> isArmTarget
    54 
    +    -- The explicit support list is essentially a list of platforms for which
    55 
    +    -- the RTS linker has support. If the RTS linker is not supported then we
    56 
    +    -- fall back on dynamic linking:
    57 
    +    dynamicGhcProgs <- askDynGhcPrograms
    58 
    +
    59 
    +    -- Maybe this should just be false for cross compilers. But for now
    60 
    +    -- I've kept the old behaviour where it will say yes. (See #25939)
    61 
    +    return $ ((goodOs && goodArch) || dynamicGhcProgs) && (stage >= Stage1 || is_cross)

  • 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

  • utils/haddock/html-test/ref/Bug25739.html
    1 
    +<html xmlns="http://www.w3.org/1999/xhtml"
    2 
    +><head
    3 
    +  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
    4 
    +     /><meta name="viewport" content="width=device-width, initial-scale=1"
    5 
    +     /><title
    6 
    +    >Bug25739</title
    7 
    +    ><link href="#" rel="stylesheet" type="text/css" title="Linuwial"
    8 
    +     /><link rel="stylesheet" type="text/css" href="#"
    9 
    +     /><link rel="stylesheet" type="text/css" href="#"
    10 
    +     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
    11 
    +    ></script
    12 
    +    ><script type="text/x-mathjax-config"
    13 
    +    >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
    14 
    +    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
    15 
    +    ></script
    16 
    +    ></head
    17 
    +  ><body
    18 
    +  ><div id="package-header"
    19 
    +    ><span class="caption empty"
    20 
    +      >&nbsp;</span
    21 
    +      ><ul class="links" id="page-menu"
    22 
    +      ><li
    23 
    +	><a href="#"
    24 
    +	  >Contents</a
    25 
    +	  ></li
    26 
    +	><li
    27 
    +	><a href="#"
    28 
    +	  >Index</a
    29 
    +	  ></li
    30 
    +	></ul
    31 
    +      ></div
    32 
    +    ><div id="content"
    33 
    +    ><div id="module-header"
    34 
    +      ><table class="info"
    35 
    +	><tr
    36 
    +	  ><th
    37 
    +	    >Safe Haskell</th
    38 
    +	    ><td
    39 
    +	    >None</td
    40 
    +	    ></tr
    41 
    +	  ></table
    42 
    +	><p class="caption"
    43 
    +	>Bug25739</p
    44 
    +	></div
    45 
    +      ><div id="interface"
    46 
    +      ><h1
    47 
    +	>Documentation</h1
    48 
    +	><div class="top"
    49 
    +	><p class="src"
    50 
    +	  ><span class="keyword"
    51 
    +	    >data</span
    52 
    +	    > <a id="t:Bar" class="def"
    53 
    +	    >Bar</a
    54 
    +	    > :: Foo <a href="#" class="selflink"
    55 
    +	    >#</a
    56 
    +	    ></p
    57 
    +	  ></div
    58 
    +	></div
    59 
    +      ></div
    60 
    +    ></body
    61 
    +  ></html
    62 
    +>

  • utils/haddock/html-test/src/Bug25739.hs
    1 
    +{-# LANGUAGE TypeData #-}
    2 
    +
    3 
    +module Bug25739 (Bar) where
    4 
    +
    5 
    +type data Foo = Bar

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