- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/bump-win32-tarballs] 7 commits: Tick uses of wildcard/pun field binds as if using the record selector function
by Ben Gamari (＠bgamari) 30 Jun '25

30 Jun '25

Ben Gamari pushed to branch wip/bump-win32-tarballs at Glasgow Haskell Compiler / GHC Commits: 43b606bb by Florian Ragwitz at 2025-06-27T16:31:26-04:00 Tick uses of wildcard/pun field binds as if using the record selector function Fixes #17834. See Note [Record-selector ticks] for additional reasoning behind this as well as an overview of the implementation details and future improvements. - - - - - d4952549 by Ben Gamari at 2025-06-27T16:32:08-04:00 testsuite/caller-cc: Make CallerCc[123] less sensitive These were previously sensitive to irrelevant changes in program structure. To avoid this we filter out all by lines emitted by the -fcaller-cc from the profile. - - - - - b6c2d9d8 by Ben Gamari at 2025-06-30T16:14:55-04:00 Bump win32-tarballs to v0.9 - - - - - 4f63e211 by GHC GitLab CI at 2025-06-30T16:14:55-04:00 rts/LoadArchive: Handle null terminated string tables - - - - - 7cc78d40 by Tamar Christina at 2025-06-30T16:14:55-04:00 rts: rename label so name doesn't conflict with param - - - - - 0cf490fe by Tamar Christina at 2025-06-30T16:14:55-04:00 rts: Handle API set symbol versioning conflicts - - - - - e16baf62 by Tamar Christina at 2025-06-30T16:15:44-04:00 rts: Mark API set symbols as HIDDEN and correct symbol type - - - - - 10 changed files: - compiler/GHC/HsToCore/Ticks.hs - docs/users_guide/9.14.1-notes.rst - mk/get-win32-tarballs.py - rts/linker/LoadArchive.c - rts/linker/PEi386.c - + testsuite/tests/hpc/recsel/Makefile - + testsuite/tests/hpc/recsel/recsel.hs - + testsuite/tests/hpc/recsel/recsel.stdout - + testsuite/tests/hpc/recsel/test.T - testsuite/tests/profiling/should_run/caller-cc/all.T Changes: ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -1,12 +1,11 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) Galois, 2006 (c) University of Glasgow, 2007 +(c) Florian Ragwitz, 2025 -} module GHC.HsToCore.Ticks @@ -38,7 +37,9 @@ import GHC.Utils.Logger import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Types.Name.Set hiding (FreeVars) import GHC.Types.Name import GHC.Types.CostCentre @@ -48,6 +49,7 @@ import GHC.Types.ProfAuto import Control.Monad import Data.List (isSuffixOf, intersperse) +import Data.Foldable (toList) import Trace.Hpc.Mix @@ -123,6 +125,7 @@ addTicksToBinds logger cfg , density = mkDensity tickish $ ticks_profAuto cfg , this_mod = mod , tickishType = tickish + , recSelBinds = emptyVarEnv } (binds',_,st') = unTM (addTickLHsBinds binds) env st in (binds', st') @@ -224,8 +227,7 @@ addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds , abs_exports = abs_exports }))) = - withEnv add_exports $ - withEnv add_inlines $ do + withEnv (add_rec_sels . add_inlines . add_exports) $ do binds' <- addTickLHsBinds binds return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' } where @@ -247,6 +249,12 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports , isInlinePragma (idInlinePragma pid) ] } + add_rec_sels env = + env{ recSelBinds = recSelBinds env `extendVarEnvList` + [ (abe_mono, abe_poly) + | ABE{ abe_poly, abe_mono } <- abs_exports + , RecSelId{} <- [idDetails abe_poly] ] } + addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do let name = getOccString id decl_path <- getPathEntry @@ -261,6 +269,10 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches tickish <- tickishType `liftM` getEnv case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do + -- See Note [Record-selector ticks] + selTick <- recSelTick id + case selTick of { Just tick -> tick_rec_sel tick; _ -> do + (fvs, mg) <- getFreeVars $ addPathEntry name $ @@ -288,7 +300,40 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches let mbCons = maybe Prelude.id (:) return $ L pos $ funBind { fun_matches = mg , fun_ext = second (tick `mbCons`) (fun_ext funBind) } - } + } } + where + -- See Note [Record-selector ticks] + tick_rec_sel tick = + pure $ L pos $ funBind { fun_ext = second (tick :) (fun_ext funBind) } + + +-- Note [Record-selector ticks] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Users expect (see #17834) that accessing a record field by its name using +-- NamedFieldPuns or RecordWildCards will mark it as covered. This is very +-- reasonable, because otherwise the use of those two language features will +-- produce unnecessary noise in coverage reports, distracting from real +-- coverage problems. +-- +-- Because of that, GHC chooses to treat record selectors specially for +-- coverage purposes to improve the developer experience. +-- +-- This is done by keeping track of which 'Id's are effectively bound to +-- record fields (using NamedFieldPuns or RecordWildCards) in 'TickTransEnv's +-- 'recSelBinds', and making 'HsVar's corresponding to those fields tick the +-- appropriate box when executed. +-- +-- To enable that, we also treat 'FunBind's for record selector functions +-- specially. We only create a TopLevelBox for the record selector function, +-- skipping the ExpBox that'd normally be created. This simplifies the re-use +-- of ticks for the same record selector, and is done by not recursing into +-- the fun_matches match group for record selector functions. +-- +-- This scheme could be extended further in the future, making coverage for +-- constructor fields (named or even positional) mean that the field was +-- accessed at run-time. For the time being, we only cover NamedFieldPuns and +-- RecordWildCards binds to cover most practical use-cases while keeping it +-- simple. -- TODO: Revisit this addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs @@ -471,7 +516,10 @@ addBinTickLHsExpr boxLabel e@(L pos e0) -- in the addTickLHsExpr family of functions.) addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e +-- See Note [Record-selector ticks] +addTickHsExpr e@(HsVar _ (L _ id)) = + freeVar id >> recSelTick id >>= pure . maybe e wrap + where wrap tick = XExpr . HsTick tick . noLocA $ e addTickHsExpr e@(HsIPVar {}) = return e addTickHsExpr e@(HsOverLit {}) = return e addTickHsExpr e@(HsOverLabel{}) = return e @@ -532,7 +580,7 @@ addTickHsExpr (HsMultiIf ty alts) ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts ; return $ HsMultiIf ty alts' } addTickHsExpr (HsLet x binds e) = - bindLocals (collectLocalBinders CollNoDictBinders binds) $ do + bindLocals binds $ do binds' <- addTickHsLocalBinds binds -- to think about: !patterns. e' <- addTickLHsExprLetBody e return (HsLet x binds' e') @@ -580,6 +628,7 @@ addTickHsExpr e@(HsUntypedSplice{}) = return e addTickHsExpr e@(HsGetField {}) = return e addTickHsExpr e@(HsProjection {}) = return e addTickHsExpr (HsProc x pat cmdtop) = + bindLocals pat $ liftM2 (HsProc x) (addTickLPat pat) (traverse (addTickHsCmdTop) cmdtop) @@ -646,19 +695,17 @@ addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} -> Match GhcTc (L -> TM (Match GhcTc (LHsExpr GhcTc)) addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = L _ pats , m_grhss = gRHSs }) = - bindLocals (collectPatsBinders CollNoDictBinders pats) $ do + bindLocals pats $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs return $ match { m_grhss = gRHSs' } addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) addTickGRHSs isOneOfMany isLambda isDoExp (GRHSs x guarded local_binds) = - bindLocals binders $ do + bindLocals local_binds $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp)) guarded return $ GRHSs x guarded' local_binds' - where - binders = collectLocalBinders CollNoDictBinders local_binds addTickGRHS :: Bool -> Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)) @@ -697,7 +744,7 @@ addTickLStmts isGuard stmts = do addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a) addTickLStmts' isGuard lstmts res - = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $ + = bindLocals lstmts $ do { lstmts' <- mapM (traverse (addTickStmt isGuard)) lstmts ; a <- res ; return (lstmts', a) } @@ -710,6 +757,7 @@ addTickStmt _isGuard (LastStmt x e noret ret) = (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) addTickStmt _isGuard (BindStmt xbs pat e) = + bindLocals pat $ liftM4 (\b f -> BindStmt $ XBindStmtTc { xbstc_bindOp = b , xbstc_boundResultType = xbstc_boundResultType xbs @@ -770,17 +818,19 @@ addTickApplicativeArg isGuard (op, arg) = liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where addTickArg (ApplicativeArgOne m_fail pat expr isBody) = - ApplicativeArgOne - <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail - <*> addTickLPat pat - <*> addTickLHsExpr expr - <*> pure isBody + bindLocals pat $ + ApplicativeArgOne + <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail + <*> addTickLPat pat + <*> addTickLHsExpr expr + <*> pure isBody addTickArg (ApplicativeArgMany x stmts ret pat ctxt) = - (ApplicativeArgMany x) - <$> addTickLStmts isGuard stmts - <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret)) - <*> addTickLPat pat - <*> pure ctxt + bindLocals pat $ + ApplicativeArgMany x + <$> addTickLStmts isGuard stmts + <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret)) + <*> addTickLPat pat + <*> pure ctxt addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc) @@ -871,7 +921,7 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = (addTickLHsCmd c2) (addTickLHsCmd c3) addTickHsCmd (HsCmdLet x binds c) = - bindLocals (collectLocalBinders CollNoDictBinders binds) $ do + bindLocals binds $ do binds' <- addTickHsLocalBinds binds -- to think about: !patterns. c' <- addTickLHsCmd c return (HsCmdLet x binds' c') @@ -907,18 +957,16 @@ addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) addTickCmdMatch match@(Match { m_pats = L _ pats, m_grhss = gRHSs }) = - bindLocals (collectPatsBinders CollNoDictBinders pats) $ do + bindLocals pats $ do gRHSs' <- addTickCmdGRHSs gRHSs return $ match { m_grhss = gRHSs' } addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) addTickCmdGRHSs (GRHSs x guarded local_binds) = - bindLocals binders $ do + bindLocals local_binds $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (traverse addTickCmdGRHS) guarded return $ GRHSs x guarded' local_binds' - where - binders = collectLocalBinders CollNoDictBinders local_binds addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is @@ -937,15 +985,14 @@ addTickLCmdStmts stmts = do addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) addTickLCmdStmts' lstmts res - = bindLocals binders $ do + = bindLocals lstmts $ do lstmts' <- mapM (traverse addTickCmdStmt) lstmts a <- res return (lstmts', a) - where - binders = collectLStmtsBinders CollNoDictBinders lstmts addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) addTickCmdStmt (BindStmt x pat c) = + bindLocals pat $ liftM2 (BindStmt x) (addTickLPat pat) (addTickLHsCmd c) @@ -1006,11 +1053,13 @@ addTickArithSeqInfo (FromThenTo e1 e2 e3) = data TickTransState = TT { ticks :: !(SizedSeq Tick) , ccIndices :: !CostCentreState + , recSelTicks :: !(IdEnv CoreTickish) } initTTState :: TickTransState initTTState = TT { ticks = emptySS , ccIndices = newCostCentreState + , recSelTicks = emptyVarEnv } addMixEntry :: Tick -> TM Int @@ -1021,6 +1070,10 @@ addMixEntry ent = do } return c +addRecSelTick :: Id -> CoreTickish -> TM () +addRecSelTick sel tick = + setState $ \s -> s{ recSelTicks = extendVarEnv (recSelTicks s) sel tick } + data TickTransEnv = TTE { fileName :: FastString , density :: TickDensity , tte_countEntries :: !Bool @@ -1033,6 +1086,7 @@ data TickTransEnv = TTE { fileName :: FastString , blackList :: Set RealSrcSpan , this_mod :: Module , tickishType :: TickishType + , recSelBinds :: IdEnv Id } -- deriving Show @@ -1154,12 +1208,13 @@ ifGoodTickSrcSpan pos then_code else_code = do good <- isGoodTickSrcSpan pos if good then then_code else else_code -bindLocals :: [Id] -> TM a -> TM a -bindLocals new_ids (TM m) - = TM $ \ env st -> - case m env{ inScope = inScope env `extendVarSetList` new_ids } st of - (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') - where occs = [ nameOccName (idName id) | id <- new_ids ] +bindLocals :: (CollectBinders bndr, CollectFldBinders bndr) => bndr -> TM a -> TM a +bindLocals from (TM m) = TM $ \env st -> + case m (with_bnds env) st of + (r, fv, st') -> (r, fv `delListFromOccEnv` (map (nameOccName . idName) new_bnds), st') + where with_bnds e = e{ inScope = inScope e `extendVarSetList` new_bnds + , recSelBinds = recSelBinds e `plusVarEnv` collectFldBinds from } + new_bnds = collectBinds from withBlackListed :: SrcSpan -> TM a -> TM a withBlackListed (RealSrcSpan ss _) = withEnv (\ env -> env { blackList = Set.insert ss (blackList env) }) @@ -1186,6 +1241,17 @@ allocTickBox boxLabel countEntries topOnly pos m tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) return (this_loc (XExpr $ HsTick tickish $ this_loc e)) +recSelTick :: Id -> TM (Maybe CoreTickish) +recSelTick id = ifDensity TickForCoverage maybe_tick (pure Nothing) + where + maybe_tick = getEnv >>= + maybe (pure Nothing) tick . (`lookupVarEnv` id) . recSelBinds + tick sel = getState >>= + maybe (alloc sel) (pure . Just) . (`lookupVarEnv` sel) . recSelTicks + alloc sel = allocATickBox (box sel) False False (getSrcSpan sel) noFVs + >>= traverse (\t -> t <$ addRecSelTick sel t) + box sel = TopLevelBox [getOccString sel] + -- the tick application inherits the source position of its -- expression argument to support nested box allocations allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars @@ -1288,3 +1354,98 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 matchCount :: LMatch GhcTc body -> Int matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss + +-- | Convenience class used by 'bindLocals' to collect new bindings from +-- various parts of he AST. Just delegates to +-- 'collect{Pat,Pats,Local,LStmts}Binders' from 'GHC.Hs.Utils' as appropriate. +class CollectBinders a where + collectBinds :: a -> [Id] + +-- | Variant of 'CollectBinders' which collects information on which locals +-- are bound to record fields (currently only via 'RecordWildCards' or +-- 'NamedFieldPuns') to enable better coverage support for record selectors. +-- +-- See Note [Record-selector ticks]. +class CollectFldBinders a where + collectFldBinds :: a -> IdEnv Id + +instance CollectBinders (LocatedA (Pat GhcTc)) where + collectBinds = collectPatBinders CollNoDictBinders +instance CollectBinders [LocatedA (Pat GhcTc)] where + collectBinds = collectPatsBinders CollNoDictBinders +instance CollectBinders (HsLocalBinds GhcTc) where + collectBinds = collectLocalBinders CollNoDictBinders +instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsExpr GhcTc)))] where + collectBinds = collectLStmtsBinders CollNoDictBinders +instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsCmd GhcTc)))] where + collectBinds = collectLStmtsBinders CollNoDictBinders + +instance (CollectFldBinders a) => CollectFldBinders [a] where + collectFldBinds = foldr (flip plusVarEnv . collectFldBinds) emptyVarEnv +instance (CollectFldBinders e) => CollectFldBinders (GenLocated l e) where + collectFldBinds = collectFldBinds . unLoc +instance CollectFldBinders (Pat GhcTc) where + collectFldBinds ConPat{ pat_args = RecCon HsRecFields{ rec_flds, rec_dotdot } } = + collectFldBinds rec_flds `plusVarEnv` plusVarEnvList (zipWith fld_bnds [0..] rec_flds) + where n_explicit | Just (L _ (RecFieldsDotDot n)) <- rec_dotdot = n + | otherwise = length rec_flds + fld_bnds n (L _ HsFieldBind{ hfbLHS = L _ FieldOcc{ foLabel = L _ sel } + , hfbRHS = L _ (VarPat _ (L _ var)) + , hfbPun }) + | hfbPun || n >= n_explicit = unitVarEnv var sel + fld_bnds _ _ = emptyVarEnv + collectFldBinds ConPat{ pat_args = PrefixCon pats } = collectFldBinds pats + collectFldBinds ConPat{ pat_args = InfixCon p1 p2 } = collectFldBinds [p1, p2] + collectFldBinds (LazyPat _ pat) = collectFldBinds pat + collectFldBinds (BangPat _ pat) = collectFldBinds pat + collectFldBinds (AsPat _ _ pat) = collectFldBinds pat + collectFldBinds (ViewPat _ _ pat) = collectFldBinds pat + collectFldBinds (ParPat _ pat) = collectFldBinds pat + collectFldBinds (ListPat _ pats) = collectFldBinds pats + collectFldBinds (TuplePat _ pats _) = collectFldBinds pats + collectFldBinds (SumPat _ pats _ _) = collectFldBinds pats + collectFldBinds (SigPat _ pat _) = collectFldBinds pat + collectFldBinds (XPat exp) = collectFldBinds exp + collectFldBinds VarPat{} = emptyVarEnv + collectFldBinds WildPat{} = emptyVarEnv + collectFldBinds OrPat{} = emptyVarEnv + collectFldBinds LitPat{} = emptyVarEnv + collectFldBinds NPat{} = emptyVarEnv + collectFldBinds NPlusKPat{} = emptyVarEnv + collectFldBinds SplicePat{} = emptyVarEnv + collectFldBinds EmbTyPat{} = emptyVarEnv + collectFldBinds InvisPat{} = emptyVarEnv +instance (CollectFldBinders r) => CollectFldBinders (HsFieldBind l r) where + collectFldBinds = collectFldBinds . hfbRHS +instance CollectFldBinders XXPatGhcTc where + collectFldBinds (CoPat _ pat _) = collectFldBinds pat + collectFldBinds (ExpansionPat _ pat) = collectFldBinds pat +instance CollectFldBinders (HsLocalBinds GhcTc) where + collectFldBinds (HsValBinds _ bnds) = collectFldBinds bnds + collectFldBinds HsIPBinds{} = emptyVarEnv + collectFldBinds EmptyLocalBinds{} = emptyVarEnv +instance CollectFldBinders (HsValBinds GhcTc) where + collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds + collectFldBinds (XValBindsLR (NValBinds bnds _)) = collectFldBinds (map snd bnds) +instance CollectFldBinders (HsBind GhcTc) where + collectFldBinds PatBind{ pat_lhs } = collectFldBinds pat_lhs + collectFldBinds (XHsBindsLR AbsBinds{ abs_exports, abs_binds }) = + mkVarEnv [ (abe_poly, sel) + | ABE{ abe_poly, abe_mono } <- abs_exports + , Just sel <- [lookupVarEnv monos abe_mono] ] + where monos = collectFldBinds abs_binds + collectFldBinds VarBind{} = emptyVarEnv + collectFldBinds FunBind{} = emptyVarEnv + collectFldBinds PatSynBind{} = emptyVarEnv +instance CollectFldBinders (Stmt GhcTc e) where + collectFldBinds (BindStmt _ pat _) = collectFldBinds pat + collectFldBinds (LetStmt _ bnds) = collectFldBinds bnds + collectFldBinds (ParStmt _ xs _ _) = collectFldBinds [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss] + collectFldBinds TransStmt{ trS_stmts } = collectFldBinds trS_stmts + collectFldBinds RecStmt{ recS_stmts } = collectFldBinds recS_stmts + collectFldBinds (XStmtLR (ApplicativeStmt _ args _)) = collectFldBinds (map snd args) + collectFldBinds LastStmt{} = emptyVarEnv + collectFldBinds BodyStmt{} = emptyVarEnv +instance CollectFldBinders (ApplicativeArg GhcTc) where + collectFldBinds ApplicativeArgOne{ app_arg_pattern } = collectFldBinds app_arg_pattern + collectFldBinds ApplicativeArgMany{ bv_pattern } = collectFldBinds bv_pattern ===================================== docs/users_guide/9.14.1-notes.rst ===================================== @@ -138,6 +138,11 @@ Compiler uses of the now deprecated ``pattern`` namespace specifier in import/export lists. See `GHC Proposal #581, section 2.3 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0581-n…>`_. +- Code coverage (:ghc-flag:`-fhpc`) now treats uses of record fields via + :extension:`RecordWildCards` or :extension:`NamedFieldPuns` as if the fields + were accessed using the generated record selector functions, marking the fields + as covered in coverage reports (:ghc-ticket:`17834`). + GHCi ~~~~ ===================================== mk/get-win32-tarballs.py ===================================== @@ -8,7 +8,7 @@ import argparse import sys from sys import stderr -TARBALL_VERSION = '0.8' +TARBALL_VERSION = '0.9' BASE_URL = "https://downloads.haskell.org/ghc/mingw/{}".format(TARBALL_VERSION) DEST = Path('ghc-tarballs/mingw-w64') ARCHS = ['x86_64', 'sources'] ===================================== rts/linker/LoadArchive.c ===================================== @@ -223,21 +223,22 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, char* gnuFileIndex, pathchar* path, size_t* thisFileNameSize, size_t* fileNameSize) { - int n; char *fileName = *fileName_; if (isdigit(fileName[1])) { - int i; - for (n = 2; isdigit(fileName[n]); n++) - ; - - fileName[n] = '\0'; - n = atoi(fileName + 1); if (gnuFileIndex == NULL) { errorBelch("loadArchive: GNU-variant filename " "without an index while reading from `%" PATH_FMT "'", path); return false; } + + int n; + for (n = 2; isdigit(fileName[n]); n++) + ; + + char *end; + fileName[n] = '\0'; + n = strtol(fileName + 1, &end, 10); if (n < 0 || n > gnuFileIndexSize) { errorBelch("loadArchive: GNU-variant filename " "offset %d out of range [0..%d] " @@ -245,17 +246,27 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, n, gnuFileIndexSize, path); return false; } - if (n != 0 && gnuFileIndex[n - 1] != '\n') { + + // Check that the previous entry ends with the expected + // end-of-string delimiter. +#if defined(mingw32_HOST_OS) +#define IS_SYMBOL_DELIMITER(STR) (STR =='\n' || STR == '\0') +#else +#define IS_SYMBOL_DELIMITER(STR) (STR =='\n') +#endif + if (n != 0 && !IS_SYMBOL_DELIMITER(gnuFileIndex[n - 1])) { errorBelch("loadArchive: GNU-variant filename offset " "%d invalid (range [0..%d]) while reading " "filename from `%" PATH_FMT "'", n, gnuFileIndexSize, path); return false; } - for (i = n; gnuFileIndex[i] != '\n'; i++) + + int i; + for (i = n; !IS_SYMBOL_DELIMITER(gnuFileIndex[i]); i++) ; - size_t FileNameSize = i - n - 1; + size_t FileNameSize = i - n; if (FileNameSize >= *fileNameSize) { /* Double it to avoid potentially continually increasing it by 1 */ ===================================== rts/linker/PEi386.c ===================================== @@ -342,6 +342,98 @@ Finally, we enter `ocResolve`, where we resolve relocations and and allocate jump islands (using the m32 allocator for backing storage) as necessary. + Note [Windows API Set] + ~~~~~~~~~~~~~~~~~~~~~~ + Windows has a concept called API Sets [1][2] which is intended to be Windows's + equivalent to glibc's symbolic versioning. It is also used to handle the API + surface difference between different device classes. e.g. the API might be + handled differently between a desktop and tablet. + + This is handled through two mechanisms: + + 1. Direct Forward: These use import libraries to manage to first level + redirection. So what used to be in ucrt.dll is now redirected based on + ucrt.lib. Every API now points to a possible different set of API sets + each following the API set contract: + + * The name must begin either with the string api- or ext-. + * Names that begin with api- represent APIs that exist on all Windows + editions that satisfy the API's version requirements. + * Names that begin with ext- represent APIs that may not exist on all + Windows editions. + * The name must end with the sequence l<n>-<n>-<n>, where n consists of + decimal digits. + * The body of the name can be alphanumeric characters, or dashes (-). + * The name is case insensitive. + + Here are some examples of API set contract names: + + - api-ms-win-core-ums-l1-1-0 + - ext-ms-win-com-ole32-l1-1-5 + - ext-ms-win-ntuser-window-l1-1-0 + - ext-ms-win-ntuser-window-l1-1-1 + + Forward references don't require anything special from the calling + application in that the Windows loader through "LoadLibrary" will + automatically load the right reference for you if given an API set + name including the ".dll" suffix. For example: + + INFO: DLL api-ms-win-eventing-provider-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-apiquery-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\ntdll.dll by API set + INFO: DLL api-ms-win-core-processthreads-l1-1-3.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-processthreads-l1-1-2.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-processthreads-l1-1-1.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-processthreads-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-registry-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-heap-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-heap-l2-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-memory-l1-1-1.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-memory-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-memory-l1-1-2.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + INFO: DLL api-ms-win-core-handle-l1-1-0.dll was redirected to C:\WINDOWS\SYSTEM32\kernelbase.dll by API set + + Which shows how the loader has redirected some of the references used + by ghci. + + Historically though we've treated shared libs lazily. We would load\ + the shared library, but not resolve the symbol immediately and wait until + the symbol is requested to iterate in order through the shared libraries. + + This assumes that you ever only had one version of a symbol. i.e. we had + an assumption that all exported symbols in different shared libraries + should be the same, because most of the time they come from re-exporting + from a base library. This is a bit of a weak assumption and doesn't hold + with API Sets. + + For that reason the loader now resolves symbols immediately, and because + we now resolve using BIND_NOW we must make sure that a symbol loaded + through an OC has precedent because the BIND_NOW refernce was not asked + for. For that reason we load the symbols for API sets with the + SYM_TYPE_DUP_DISCARD flag set. + + 2. Reverse forwarders: This is when the application has a direct reference + to the old name of an API. e.g. if GHC still used "msvcrt.dll" or + "ucrt.dll" we would have had to deal with this case. In this case the + loader intercepts the call and if it exists the dll is loaded. There is + an extra indirection as you go from foo.dll => api-ms-foo-1.dll => foo_imp.dll + + But if the API doesn't exist on the device it's resolved to a stub in the + API set that if called will result in an error should it be called [3]. + + This means that usages of GetProcAddress and LoadLibrary to check for the + existance of a function aren't safe, because they'll always succeed, but may + result in a pointer to the stub rather than the actual function. + + WHat does this mean for the RTS linker? Nothing. We don't have a fallback + for if the function doesn't exist. The RTS is merely just executing what + it was told to run. It's writers of libraries that have to be careful when + doing dlopen()/LoadLibrary. + + + [1] https://learn.microsoft.com/en-us/windows/win32/apiindex/windows-apisets + [2] https://mingwpy.github.io/ucrt.html#api-set-implementation + [3] https://learn.microsoft.com/en-us/windows/win32/apiindex/detect-api-set-ava… + */ #include "Rts.h" @@ -882,7 +974,7 @@ addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded ) goto error; } } else { - goto loaded; /* We're done. DLL has been loaded. */ + goto loaded_ok; /* We're done. DLL has been loaded. */ } } } @@ -890,7 +982,7 @@ addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded ) // We failed to load goto error; -loaded: +loaded_ok: addLoadedDll(&loaded_dll_cache, dll_name, instance); addDLLHandle(buf, instance); if (loaded) { @@ -1055,7 +1147,8 @@ bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f // We must call `addDLL_PEi386` directly rather than `addDLL` because `addDLL` // is now a wrapper around `loadNativeObj` which acquires a lock which we // already have here. - const char* result = addDLL_PEi386(dll, NULL); + HINSTANCE instance; + const char* result = addDLL_PEi386(dll, &instance); stgFree(image); @@ -1069,6 +1162,24 @@ bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f } stgFree(dll); + + // See Note [Windows API Set] + // We must immediately tie the symbol to the shared library. The easiest + // way is to load the symbol immediately. We already have all the + // information so might as well + SymbolAddr* sym = lookupSymbolInDLL_PEi386 (symbol, instance, dll, NULL); + ASSERT(sym); + // The symbol must have been found, and we can add it to the RTS symbol table + IF_DEBUG(linker, debugBelch("checkAndLoadImportLibrary: resolved symbol %s to %p\n", symbol, sym)); + // Because the symbol has been loaded before we actually need it, if a + // stronger reference wants to add a duplicate we should discard this + // one to preserve link order. + SymType symType = SYM_TYPE_DUP_DISCARD | SYM_TYPE_HIDDEN; + symType |= hdr.Type == IMPORT_OBJECT_CODE ? SYM_TYPE_CODE : SYM_TYPE_DATA; + + if (!ghciInsertSymbolTable(dll, symhash, symbol, sym, false, symType, NULL)) + return false; + return true; } ===================================== testsuite/tests/hpc/recsel/Makefile ===================================== @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk ===================================== testsuite/tests/hpc/recsel/recsel.hs ===================================== @@ -0,0 +1,49 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns, Arrows #-} + +import Control.Monad.Identity +import Control.Arrow (runKleisli, arr, returnA) +import Data.Maybe +import Data.List +import Data.Bifunctor +import Trace.Hpc.Mix +import Trace.Hpc.Tix +import Trace.Hpc.Reflect + +data Foo = Foo { fooA, fooB, fooC, fooD, fooE, fooF, fooG, fooH, fooI + , fooJ, fooK, fooL, fooM, fooN, fooO :: Int } +data Bar = Bar { barFoo :: Foo } + +fAB Foo{..} = fooA + fooB +fC Foo{fooC} = fooC +fD x Foo{..} = fromMaybe 0 $ if x then Just fooD else Nothing +fE Bar{barFoo = Foo{..}} = fooE +fF Foo{fooF = f} = f +fG f = let Foo{..} = f in fooG +fH f = runIdentity $ do + Foo{..} <- pure f + return fooH +fI f = runIdentity $ do + let Foo{..} = f + return fooI +fJ f = [ fooJ | let Foo{..} = f ] !! 0 +fK = runIdentity . runKleisli (proc f -> do + Foo{..} <- arr id -< f + returnA -< fooK) +fL = runIdentity . runKleisli (proc f -> do + let Foo{..} = f; + returnA -< fooL) +fM f | Foo{..} <- f = fooM +fN f = fooN f +fO = runIdentity . runKleisli (proc Foo{..} -> returnA -< fooO) + +recSel (n, TopLevelBox [s]) | any (`isPrefixOf` s) ["foo", "bar"] = Just (n, s) +recSel _ = Nothing + +main = do + let foo = Foo 42 23 0 1 2 3 4 5 6 7 0xaffe 9 10 11 12 + mapM_ (print . ($ foo)) + [fAB, fC, fD False, fE . Bar, fF, fG, fH, fI, fJ, fK, fL, fM, fN, fO] + (Mix _ _ _ _ mixs) <- readMix [".hpc"] (Left "Main") + let sels = mapMaybe recSel . zip [0..] $ map snd mixs + (Tix [TixModule "Main" _ _ tix]) <- examineTix + mapM_ print . sortOn snd $ map (first (tix !!)) sels ===================================== testsuite/tests/hpc/recsel/recsel.stdout ===================================== @@ -0,0 +1,30 @@ +65 +0 +0 +2 +3 +4 +5 +6 +7 +45054 +9 +10 +11 +12 +(0,"barFoo") +(1,"fooA") +(1,"fooB") +(1,"fooC") +(0,"fooD") +(1,"fooE") +(0,"fooF") +(1,"fooG") +(1,"fooH") +(1,"fooI") +(1,"fooJ") +(1,"fooK") +(1,"fooL") +(1,"fooM") +(1,"fooN") +(1,"fooO") ===================================== testsuite/tests/hpc/recsel/test.T ===================================== @@ -0,0 +1,7 @@ +setTestOpts([omit_ghci, when(fast(), skip), js_skip]) + +test('recsel', + [ignore_extension, + when(arch('wasm32'), fragile(23243))], + compile_and_run, ['-fhpc']) + ===================================== testsuite/tests/profiling/should_run/caller-cc/all.T ===================================== @@ -8,6 +8,7 @@ setTestOpts(only_ways(prof_ways)) setTestOpts(extra_files(['Main.hs'])) setTestOpts(extra_run_opts('7')) setTestOpts(grep_prof("Main.hs")) +setTestOpts(grep_prof("calling:")) # N.B. Main.hs is stolen from heapprof001. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac1780b62a270952a983128f385f88… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ac1780b62a270952a983128f385f88… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/26039] Bump default language edition to GHC2024
by Rodrigo Mesquita (＠alt-romes) 30 Jun '25

30 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/26039 at Glasgow Haskell Compiler / GHC Commits: a05047bd by Rodrigo Mesquita at 2025-06-30T20:40:12+01:00 Bump default language edition to GHC2024 As per the accepted ghc-proposal#632 Fixes #26039 - - - - - 41 changed files: - compiler/GHC/Driver/Flags.hs - testsuite/tests/ado/all.T - testsuite/tests/annotations/should_fail/all.T - testsuite/tests/array/should_run/all.T - testsuite/tests/core-to-stg/all.T - testsuite/tests/deSugar/should_fail/all.T - testsuite/tests/deriving/should_compile/all.T - testsuite/tests/deriving/should_fail/all.T - testsuite/tests/dmdanal/sigs/all.T - testsuite/tests/gadt/all.T - testsuite/tests/ghci.debugger/scripts/all.T - testsuite/tests/ghci/prog-mhu002/all.T - testsuite/tests/ghci/scripts/Makefile - testsuite/tests/ghci/should_run/all.T - testsuite/tests/indexed-types/should_compile/all.T - testsuite/tests/linear/should_fail/all.T - testsuite/tests/module/all.T - testsuite/tests/overloadedrecflds/should_fail/all.T - testsuite/tests/parser/should_fail/all.T - testsuite/tests/partial-sigs/should_compile/all.T - testsuite/tests/polykinds/all.T - testsuite/tests/programs/andy_cherry/test.T - testsuite/tests/rename/should_fail/all.T - testsuite/tests/roles/should_fail/all.T - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/HaddockIssue849.stdout - testsuite/tests/showIface/HaddockOpts.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/MagicHashInHaddocks.stdout - testsuite/tests/showIface/Makefile - testsuite/tests/showIface/NoExportList.stdout - testsuite/tests/showIface/PragmaDocs.stdout - testsuite/tests/showIface/ReExports.stdout - testsuite/tests/simplCore/T9646/test.T - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/th/all.T - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_run/all.T - testsuite/tests/vdq-rta/should_fail/all.T - testsuite/tests/warnings/should_fail/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a05047bdf2fad15fbafd50c5583b093… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a05047bdf2fad15fbafd50c5583b093… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-8] Big refactor of breakpoints internal representation
by Rodrigo Mesquita (＠alt-romes) 30 Jun '25

30 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-8 at Glasgow Haskell Compiler / GHC Commits: 40535c58 by Rodrigo Mesquita at 2025-06-30T20:21:50+01:00 Big refactor of breakpoints internal representation Big better At this point we now have to go and re-work the BrkArrays to consider internal breakpoints (generated in StgGen) and multi-threading. tomorrow. Continue refactor Lots of progress littel better compiler: make ModBreaks serializable Mais... BRK_FUN in rts Fixes Tweaks Checkpoint but segfaults in GC Start part 4.... simpler allow allocating breakarrays outside of linking but in the linker env still disassemble tack todo - - - - - 33 changed files: - compiler/GHC.hs - compiler/GHC/ByteCode/Asm.hs - + compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/StgToByteCode.hs - − compiler/GHC/Types/Breakpoint.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - rts/Disassembler.c - rts/Exception.cmm - rts/Interpreter.c The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40535c58d09dfbee8d49c771017cd59… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40535c58d09dfbee8d49c771017cd59… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-8] 7 commits: cleanup: Pass the HUG to readModBreaks, not HscEnv
by Rodrigo Mesquita (＠alt-romes) 30 Jun '25

30 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-8 at Glasgow Haskell Compiler / GHC Commits: e610933e by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 cleanup: Pass the HUG to readModBreaks, not HscEnv A minor cleanup. The associated history and setupBreakpoint functions are changed accordingly. - - - - - ba684e79 by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 cleanup: Move readModBreaks to GHC.Runtime.Interpreter With some small docs changes - - - - - 2764f1f6 by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 cleanup: Move interpreterProfiled to Interp.Types Moves interpreterProfiled and interpreterDynamic to GHC.Runtime.Interpreter.Types from GHC.Runtime.Interpreter. - - - - - 8c302392 by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 cleanup: Don't import GHC in Debugger.Breakpoints Remove the top-level import GHC from GHC.Runtime.Debugger.Breakpoints This makes the module dependencies more granular and cleans up the qualified imports from the code. - - - - - affa8dbc by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 refactor: Use BreakpointId in Core and Ifaces - - - - - 819bb93f by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 stg2bc: Derive BcM via ReaderT StateT A small refactor that simplifies GHC.StgToByteCode by deriving-via the Monad instances for BcM. This is done along the lines of previous similar refactors like 72b54c0760bbf85be1f73c1a364d4701e5720465. - - - - - f4d0369a by Rodrigo Mesquita at 2025-06-30T20:13:15+01:00 Big refactor of breakpoints internal representation Big better At this point we now have to go and re-work the BrkArrays to consider internal breakpoints (generated in StgGen) and multi-threading. tomorrow. Continue refactor Lots of progress littel better compiler: make ModBreaks serializable Mais... BRK_FUN in rts Fixes Tweaks Checkpoint but segfaults in GC Start part 4.... simpler allow allocating breakarrays outside of linking but in the linker env still disassemble tack todo The BreakArray construction at link time was originally done by Cheng. Co-authored-by: Cheng Shao <terrorjack(a)type.dance> - - - - - 48 changed files: - compiler/GHC.hs - compiler/GHC/ByteCode/Asm.hs - + compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/FVs.hs - compiler/GHC/StgToByteCode.hs - − compiler/GHC/Types/Breakpoint.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - rts/Disassembler.c - rts/Exception.cmm - rts/Interpreter.c The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6502cff1107240e8ddcdd9f57e4a21… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6502cff1107240e8ddcdd9f57e4a21… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-9] 6 commits: cleanup: Pass the HUG to readModBreaks, not HscEnv
by Rodrigo Mesquita (＠alt-romes) 30 Jun '25

30 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-9 at Glasgow Haskell Compiler / GHC Commits: e610933e by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 cleanup: Pass the HUG to readModBreaks, not HscEnv A minor cleanup. The associated history and setupBreakpoint functions are changed accordingly. - - - - - ba684e79 by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 cleanup: Move readModBreaks to GHC.Runtime.Interpreter With some small docs changes - - - - - 2764f1f6 by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 cleanup: Move interpreterProfiled to Interp.Types Moves interpreterProfiled and interpreterDynamic to GHC.Runtime.Interpreter.Types from GHC.Runtime.Interpreter. - - - - - 8c302392 by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 cleanup: Don't import GHC in Debugger.Breakpoints Remove the top-level import GHC from GHC.Runtime.Debugger.Breakpoints This makes the module dependencies more granular and cleans up the qualified imports from the code. - - - - - affa8dbc by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 refactor: Use BreakpointId in Core and Ifaces - - - - - 819bb93f by Rodrigo Mesquita at 2025-06-30T20:10:58+01:00 stg2bc: Derive BcM via ReaderT StateT A small refactor that simplifies GHC.StgToByteCode by deriving-via the Monad instances for BcM. This is done along the lines of previous similar refactors like 72b54c0760bbf85be1f73c1a364d4701e5720465. - - - - - 27 changed files: - compiler/GHC.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/FVs.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Types/Breakpoint.hs - compiler/GHC/Types/Tickish.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -1899,7 +1899,7 @@ getGHCiMonad :: GhcMonad m => m Name getGHCiMonad = fmap (ic_monad . hsc_IC) getSession getHistorySpan :: GhcMonad m => History -> m SrcSpan -getHistorySpan h = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.getHistorySpan hsc_env h +getHistorySpan h = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.getHistorySpan (hsc_HUG hsc_env) h obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term obtainTermFromVal bound force ty a = withSession $ \hsc_env -> ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -287,7 +287,7 @@ exprs_fvs :: [CoreExpr] -> FV exprs_fvs exprs = mapUnionFV expr_fvs exprs tickish_fvs :: CoreTickish -> FV -tickish_fvs (Breakpoint _ _ ids _) = FV.mkFVs ids +tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids tickish_fvs _ = emptyFV {- ********************************************************************** @@ -759,8 +759,8 @@ freeVars = go , AnnTick tickish expr2 ) where expr2 = go expr - tickishFVs (Breakpoint _ _ ids _) = mkDVarSet ids - tickishFVs _ = emptyDVarSet + tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids + tickishFVs _ = emptyDVarSet go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -897,8 +897,8 @@ lintCoreExpr (Cast expr co) lintCoreExpr (Tick tickish expr) = do { case tickish of - Breakpoint _ _ ids _ -> forM_ ids $ \id -> lintIdOcc id 0 - _ -> return () + Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0 + _ -> return () ; markAllJoinsBadIf block_joins $ lintCoreExpr expr } where block_joins = not (tickish `tickishScopesLike` SoftScope) ===================================== compiler/GHC/Core/Map/Expr.hs ===================================== @@ -198,11 +198,10 @@ eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where eqDeBruijnTickish :: DeBruijn CoreTickish -> DeBruijn CoreTickish -> Bool eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where - go (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod) + go (Breakpoint lext lid lids) (Breakpoint rext rid rids) = lid == rid && D env1 lids == D env2 rids && lext == rext - && lmod == rmod go l r = l == r -- Compares for equality, modulo alpha ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2501,7 +2501,7 @@ occAnal env (Tick tickish body) -- For a non-soft tick scope, we can inline lambdas only, so we -- abandon tail calls, and do markAllInsideLam too: usage_lam - | Breakpoint _ _ ids _ <- tickish + | Breakpoint _ _ ids <- tickish = -- Never substitute for any of the Ids in a Breakpoint addManyOccs usage_lam (mkVarSet ids) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1461,8 +1461,8 @@ simplTick env tickish expr cont simplTickish env tickish - | Breakpoint ext n ids modl <- tickish - = Breakpoint ext n (mapMaybe (getDoneId . substId env) ids) modl + | Breakpoint ext bid ids <- tickish + = Breakpoint ext bid (mapMaybe (getDoneId . substId env) ids) | otherwise = tickish -- Push type application and coercion inside a tick ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Prelude import GHC.Core import GHC.Core.Stats (exprStats) +import GHC.Types.Breakpoint import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Literal( pprLiteral ) import GHC.Types.Name( pprInfixName, pprPrefixName ) @@ -694,10 +695,10 @@ instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where ppr modl, comma, ppr ix, text ">"] - ppr (Breakpoint _ext ix vars modl) = + ppr (Breakpoint _ext bid vars) = hcat [text "break<", - ppr modl, comma, - ppr ix, + ppr (bi_tick_mod bid), comma, + ppr (bi_tick_index bid), text ">", parens (hcat (punctuate comma (map ppr vars)))] ppr (ProfNote { profNoteCC = cc, ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -602,8 +602,8 @@ substDVarSet subst@(Subst _ _ tv_env cv_env) fvs ------------------ -- | Drop free vars from the breakpoint if they have a non-variable substitution. substTickish :: Subst -> CoreTickish -> CoreTickish -substTickish subst (Breakpoint ext n ids modl) - = Breakpoint ext n (mapMaybe do_one ids) modl +substTickish subst (Breakpoint ext bid ids) + = Breakpoint ext bid (mapMaybe do_one ids) where do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst ===================================== compiler/GHC/Core/Tidy.hs ===================================== @@ -235,8 +235,8 @@ tidyAlt env (Alt con vs rhs) ------------ Tickish -------------- tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish -tidyTickish env (Breakpoint ext ix ids modl) - = Breakpoint ext ix (map (tidyVarOcc env) ids) modl +tidyTickish env (Breakpoint ext bid ids) + = Breakpoint ext bid (map (tidyVarOcc env) ids) tidyTickish _ other_tickish = other_tickish ------------ Rules -------------- ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -2492,11 +2492,10 @@ cheapEqExpr' ignoreTick e1 e2 -- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool -eqTickish env (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod) +eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids) = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids && - lext == rext && - lmod == rmod + lext == rext eqTickish _ l r = l == r -- | Finds differences between core bindings, see @diffExpr@. ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -586,8 +586,8 @@ toIfaceTickish (ProfNote cc tick push) = IfaceSCC cc tick push toIfaceTickish (HpcTick modl ix) = IfaceHpcTick modl ix toIfaceTickish (SourceNote src (LexicalFastString names)) = IfaceSource src names -toIfaceTickish (Breakpoint _ ix fv m) = - IfaceBreakpoint ix (toIfaceVar <$> fv) m +toIfaceTickish (Breakpoint _ ix fv) = + IfaceBreakpoint ix (toIfaceVar <$> fv) --------------------- toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -643,10 +643,10 @@ coreToStgArgs (arg : args) = do -- Non-type argument coreToStgTick :: Type -- type of the ticked expression -> CoreTickish -> StgTickish -coreToStgTick _ty (HpcTick m i) = HpcTick m i -coreToStgTick _ty (SourceNote span nm) = SourceNote span nm -coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope -coreToStgTick !ty (Breakpoint _ bid fvs modl) = Breakpoint ty bid fvs modl +coreToStgTick _ty (HpcTick m i) = HpcTick m i +coreToStgTick _ty (SourceNote span nm) = SourceNote span nm +coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope +coreToStgTick !ty (Breakpoint _ bid fvs) = Breakpoint ty bid fvs -- --------------------------------------------------------------------------- -- The magic for lets: ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -842,9 +842,9 @@ cpeRhsE env (Tick tickish expr) = do { body <- cpeBodyNF env expr ; return (emptyFloats, mkTick tickish' body) } where - tickish' | Breakpoint ext n fvs modl <- tickish + tickish' | Breakpoint ext bid fvs <- tickish -- See also 'substTickish' - = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) modl + = Breakpoint ext bid (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) | otherwise = tickish ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Driver.Flags (DumpFlag(..)) import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Logger +import GHC.Types.Breakpoint import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Id @@ -1235,7 +1236,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do Breakpoints -> do i <- addMixEntry me - pure (Breakpoint noExtField i ids (this_mod env)) + pure (Breakpoint noExtField (BreakpointId (this_mod env) i) ids) SourceNotes | RealSrcSpan pos' _ <- pos -> return $ SourceNote pos' $ LexicalFastString cc_name ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -56,6 +56,7 @@ import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue) import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey, constraintKindTyConKey ) +import GHC.Types.Breakpoint import GHC.Types.Unique ( hasKey ) import GHC.Iface.Type import GHC.Iface.Recomp.Binary @@ -699,7 +700,7 @@ data IfaceTickish = IfaceHpcTick Module Int -- from HpcTick x | IfaceSCC CostCentre Bool Bool -- from ProfNote | IfaceSource RealSrcSpan FastString -- from SourceNote - | IfaceBreakpoint Int [IfaceExpr] Module -- from Breakpoint + | IfaceBreakpoint BreakpointId [IfaceExpr] -- from Breakpoint data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr -- Note: IfLclName, not IfaceBndr (and same with the case binder) @@ -1848,7 +1849,7 @@ pprIfaceTickish (IfaceSCC cc tick scope) = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) pprIfaceTickish (IfaceSource src _names) = braces (pprUserRealSpan True src) -pprIfaceTickish (IfaceBreakpoint m ix fvs) +pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs) = braces (text "break" <+> ppr m <+> ppr ix <+> ppr fvs) ------------------ @@ -2198,7 +2199,7 @@ freeNamesIfaceTyConParent (IfDataInstance ax tc tys) = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys freeNamesIfTickish :: IfaceTickish -> NameSet -freeNamesIfTickish (IfaceBreakpoint _ fvs _) = +freeNamesIfTickish (IfaceBreakpoint _ fvs) = fnList freeNamesIfExpr fvs freeNamesIfTickish _ = emptyNameSet @@ -2919,7 +2920,7 @@ instance Binary IfaceTickish where put_ bh (srcSpanEndLine src) put_ bh (srcSpanEndCol src) put_ bh name - put_ bh (IfaceBreakpoint m ix fvs) = do + put_ bh (IfaceBreakpoint (BreakpointId m ix) fvs) = do putByte bh 3 put_ bh m put_ bh ix @@ -2947,7 +2948,7 @@ instance Binary IfaceTickish where 3 -> do m <- get bh ix <- get bh fvs <- get bh - return (IfaceBreakpoint m ix fvs) + return (IfaceBreakpoint (BreakpointId m ix) fvs) _ -> panic ("get IfaceTickish " ++ show h) instance Binary IfaceConAlt where @@ -3206,7 +3207,7 @@ instance NFData IfaceTickish where IfaceHpcTick m i -> rnf m `seq` rnf i IfaceSCC cc b1 b2 -> rnf cc `seq` rnf b1 `seq` rnf b2 IfaceSource src str -> rnf src `seq` rnf str - IfaceBreakpoint m i fvs -> rnf m `seq` rnf i `seq` rnf fvs + IfaceBreakpoint i fvs -> rnf i `seq` rnf fvs instance NFData IfaceConAlt where rnf = \case ===================================== compiler/GHC/Iface/Tidy.hs ===================================== @@ -955,7 +955,7 @@ dffvExpr :: CoreExpr -> DFFV () dffvExpr (Var v) = insert v dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 dffvExpr (Lam v e) = extendScope v (dffvExpr e) -dffvExpr (Tick (Breakpoint _ _ ids _) e) = mapM_ insert ids >> dffvExpr e +dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e dffvExpr (Tick _other e) = dffvExpr e dffvExpr (Cast e _) = dffvExpr e dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -1732,9 +1732,9 @@ tcIfaceTickish :: IfaceTickish -> IfL CoreTickish tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) tcIfaceTickish (IfaceSource src name) = return (SourceNote src (LexicalFastString name)) -tcIfaceTickish (IfaceBreakpoint ix fvs modl) = do +tcIfaceTickish (IfaceBreakpoint bid fvs) = do fvs' <- mapM tcIfaceExpr fvs - return (Breakpoint NoExtField ix [f | Var f <- fvs'] modl) + return (Breakpoint NoExtField bid [f | Var f <- fvs']) ------------------------- tcIfaceLit :: Literal -> IfL Literal ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -1,9 +1,12 @@ + -- | GHC API debugger module for finding and setting breakpoints. -- -- This module is user facing and is at least used by `GHCi` and `ghc-debugger` -- to find and set breakpoints. module GHC.Runtime.Debugger.Breakpoints where +import GHC.Prelude + import Control.Monad.Catch import Control.Monad import Data.Array @@ -13,10 +16,18 @@ import Data.Maybe import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as S -import GHC -import GHC.Prelude +import GHC.ByteCode.Types (BreakIndex, ModBreaks(..)) +import GHC.Driver.Env +import GHC.Driver.Monad +import GHC.Driver.Session.Inspect +import GHC.Runtime.Eval import GHC.Runtime.Eval.Utils +import GHC.Types.Name import GHC.Types.SrcLoc +import GHC.Types.Breakpoint +import GHC.Unit.Module +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModSummary import GHC.Utils.Outputable import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict @@ -44,10 +55,10 @@ findBreakByLine line arr ticks = arr ! line starts_here = [ (ix,pan) | (ix, pan) <- ticks, - GHC.srcSpanStartLine pan == line ] + srcSpanStartLine pan == line ] (comp, incomp) = partition ends_here starts_here - where ends_here (_,pan) = GHC.srcSpanEndLine pan == line + where ends_here (_,pan) = srcSpanEndLine pan == line -- | Find a breakpoint in the 'TickArray' of a module, given a line number and a column coordinate. findBreakByCoord :: (Int, Int) -> TickArray -> Maybe (BreakIndex, RealSrcSpan) @@ -63,8 +74,8 @@ findBreakByCoord (line, col) arr contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col) ] after_here = [ tick | tick@(_,pan) <- ticks, - GHC.srcSpanStartLine pan == line, - GHC.srcSpanStartCol pan >= col ] + srcSpanStartLine pan == line, + srcSpanStartCol pan >= col ] leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd @@ -112,7 +123,7 @@ resolveFunctionBreakpoint inp = do Nothing -> do -- No errors found, go and return the module info let mod = fromMaybe (panic "resolveFunctionBreakpoint") mb_mod - mb_mod_info <- GHC.getModuleInfo mod + mb_mod_info <- getModuleInfo mod case mb_mod_info of Nothing -> pure . Left $ text "Could not find ModuleInfo of " <> ppr mod @@ -120,16 +131,16 @@ resolveFunctionBreakpoint inp = do where -- Try to lookup the module for an identifier that is in scope. -- `parseName` throws an exception, if the identifier is not in scope - lookupModuleInscope :: GHC.GhcMonad m => String -> m (Maybe Module) + lookupModuleInscope :: GhcMonad m => String -> m (Maybe Module) lookupModuleInscope mod_top_lvl = do - names <- GHC.parseName mod_top_lvl - pure $ Just $ NE.head $ GHC.nameModule <$> names + names <- parseName mod_top_lvl + pure $ Just $ NE.head $ nameModule <$> names -- Lookup the Module of a module name in the module graph - lookupModuleInGraph :: GHC.GhcMonad m => String -> m (Maybe Module) + lookupModuleInGraph :: GhcMonad m => String -> m (Maybe Module) lookupModuleInGraph mod_str = do - graph <- GHC.getModuleGraph - let hmods = ms_mod <$> GHC.mgModSummaries graph + graph <- getModuleGraph + let hmods = ms_mod <$> mgModSummaries graph pure $ find ((== mod_str) . moduleNameString . moduleName) hmods -- Check validity of an identifier to set a breakpoint: @@ -137,21 +148,21 @@ resolveFunctionBreakpoint inp = do -- 2. the identifier must be in an interpreted module -- 3. the ModBreaks array for module `mod` must have an entry -- for the function - validateBP :: GHC.GhcMonad m => String -> String -> Maybe Module + validateBP :: GhcMonad m => String -> String -> Maybe Module -> m (Maybe SDoc) validateBP mod_str fun_str Nothing = pure $ Just $ quotes (text (combineModIdent mod_str (takeWhile (/= '.') fun_str))) <+> text "not in scope" validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing" validateBP _ fun_str (Just modl) = do - isInterpr <- GHC.moduleIsInterpreted modl + isInterpr <- moduleIsInterpreted modl mb_err_msg <- case isInterpr of False -> pure $ Just $ text "Module" <+> quotes (ppr modl) <+> text "is not interpreted" True -> do mb_modbreaks <- getModBreak modl let found = case mb_modbreaks of Nothing -> False - Just mb -> fun_str `elem` (intercalate "." <$> elems (GHC.modBreaks_decls mb)) + Just mb -> fun_str `elem` (intercalate "." <$> elems (modBreaks_decls mb)) if found then pure Nothing else pure $ Just $ text "No breakpoint found for" <+> quotes (text fun_str) @@ -163,13 +174,13 @@ resolveFunctionBreakpoint inp = do -- for -- (a) this binder only (it maybe a top-level or a nested declaration) -- (b) that do not have an enclosing breakpoint -findBreakForBind :: String {-^ Name of bind to break at -} -> GHC.ModBreaks -> [(BreakIndex, RealSrcSpan)] +findBreakForBind :: String {-^ Name of bind to break at -} -> ModBreaks -> [(BreakIndex, RealSrcSpan)] findBreakForBind str_name modbreaks = filter (not . enclosed) ticks where ticks = [ (index, span) - | (index, decls) <- assocs (GHC.modBreaks_decls modbreaks), + | (index, decls) <- assocs (modBreaks_decls modbreaks), str_name == intercalate "." decls, - RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ] + RealSrcSpan span _ <- [modBreaks_locs modbreaks ! index] ] enclosed (_,sp0) = any subspan ticks where subspan (_,sp) = sp /= sp0 && realSrcSpanStart sp <= realSrcSpanStart sp0 && @@ -180,53 +191,53 @@ findBreakForBind str_name modbreaks = filter (not . enclosed) ticks -------------------------------------------------------------------------------- -- | Maps line numbers to the breakpoint ticks existing at that line for a module. -type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)] +type TickArray = Array Int [(BreakIndex,RealSrcSpan)] -- | Construct the 'TickArray' for the given module. makeModuleLineMap :: GhcMonad m => Module -> m (Maybe TickArray) makeModuleLineMap m = do - mi <- GHC.getModuleInfo m - return $ mkTickArray . assocs . GHC.modBreaks_locs <$> (GHC.modInfoModBreaks =<< mi) + mi <- getModuleInfo m + return $ mkTickArray . assocs . modBreaks_locs <$> (modInfoModBreaks =<< mi) where mkTickArray :: [(BreakIndex, SrcSpan)] -> TickArray mkTickArray ticks = accumArray (flip (:)) [] (1, max_line) [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ] where - max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ] - srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ] + max_line = foldr max 0 [ srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ] + srcSpanLines pan = [ srcSpanStartLine pan .. srcSpanEndLine pan ] -- | Get the 'ModBreaks' of the given 'Module' when available -getModBreak :: GHC.GhcMonad m - => Module -> m (Maybe ModBreaks) +getModBreak :: GhcMonad m => Module -> m (Maybe ModBreaks) getModBreak m = do - mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m - pure $ GHC.modInfoModBreaks mod_info + mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m + pure $ modInfoModBreaks mod_info -------------------------------------------------------------------------------- -- Getting current breakpoint information -------------------------------------------------------------------------------- -getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan) +getCurrentBreakSpan :: GhcMonad m => m (Maybe SrcSpan) getCurrentBreakSpan = do - resumes <- GHC.getResumeContext + hug <- hsc_HUG <$> getSession + resumes <- getResumeContext case resumes of [] -> return Nothing (r:_) -> do - let ix = GHC.resumeHistoryIx r + let ix = resumeHistoryIx r if ix == 0 - then return (Just (GHC.resumeSpan r)) + then return (Just (resumeSpan r)) else do - let hist = GHC.resumeHistory r !! (ix-1) - pan <- GHC.getHistorySpan hist + let hist = resumeHistory r !! (ix-1) + pan <- liftIO $ getHistorySpan hug hist return (Just pan) -getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module) +getCurrentBreakModule :: GhcMonad m => m (Maybe Module) getCurrentBreakModule = do - resumes <- GHC.getResumeContext + resumes <- getResumeContext return $ case resumes of [] -> Nothing - (r:_) -> case GHC.resumeHistoryIx r of - 0 -> ibi_tick_mod <$> GHC.resumeBreakpointId r - ix -> Just $ GHC.getHistoryModule $ GHC.resumeHistory r !! (ix-1) + (r:_) -> case resumeHistoryIx r of + 0 -> ibi_tick_mod <$> resumeBreakpointId r + ix -> Just $ getHistoryModule $ resumeHistory r !! (ix-1) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -144,25 +144,25 @@ import qualified GHC.Unit.Home.Graph as HUG getResumeContext :: GhcMonad m => m [Resume] getResumeContext = withSession (return . ic_resume . hsc_IC) -mkHistory :: HscEnv -> ForeignHValue -> InternalBreakpointId -> IO History -mkHistory hsc_env hval ibi = History hval ibi <$> findEnclosingDecls hsc_env ibi +mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History +mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi getHistoryModule :: History -> Module getHistoryModule = ibi_tick_mod . historyBreakpointId -getHistorySpan :: HscEnv -> History -> IO SrcSpan -getHistorySpan hsc_env hist = do +getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan +getHistorySpan hug hist = do let ibi = historyBreakpointId hist - brks <- readModBreaks hsc_env (ibi_tick_mod ibi) + brks <- readModBreaks hug (ibi_tick_mod ibi) return $ modBreaks_locs brks ! ibi_tick_index ibi {- | Finds the enclosing top level function name -} -- ToDo: a better way to do this would be to keep hold of the decl_path computed -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick. -findEnclosingDecls :: HscEnv -> InternalBreakpointId -> IO [String] -findEnclosingDecls hsc_env ibi = do - brks <- readModBreaks hsc_env (ibi_tick_mod ibi) +findEnclosingDecls :: HUG.HomeUnitGraph -> InternalBreakpointId -> IO [String] +findEnclosingDecls hug ibi = do + brks <- readModBreaks hug (ibi_tick_mod ibi) return $ modBreaks_decls brks ! ibi_tick_index ibi -- | Update fixity environment in the current interactive context. @@ -349,7 +349,8 @@ handleRunStatus step expr bindings final_ids status history0 = do -- - or one of the stepping options in @EvalOpts@ caused us to stop at one EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do let ibi = evalBreakpointToId eval_break - tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi) + let hug = hsc_HUG hsc_env + tick_brks <- liftIO $ readModBreaks hug (ibi_tick_mod ibi) let span = modBreaks_locs tick_brks ! ibi_tick_index ibi decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi @@ -390,7 +391,7 @@ handleRunStatus step expr bindings final_ids status history0 = do let eval_opts = initEvalOpts dflags (enableGhcStepMode step) status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv history <- if not tracing then pure history0 else do - history1 <- liftIO $ mkHistory hsc_env apStack_fhv ibi + history1 <- liftIO $ mkHistory hug apStack_fhv ibi let !history' = history1 `consBL` history0 -- history is strict, otherwise our BoundedList is pointless. return history' @@ -443,27 +444,27 @@ resumeExec step mbCnt -- When the user specified a break ignore count, set it -- in the interpreter case (mb_brkpt, mbCnt) of - (Just brkpt, Just cnt) -> setupBreakpoint hsc_env (toBreakpointId brkpt) cnt + (Just brkpt, Just cnt) -> setupBreakpoint interp (toBreakpointId brkpt) cnt _ -> return () let eval_opts = initEvalOpts dflags (enableGhcStepMode step) status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv let prevHistoryLst = fromListBL 50 hist + hug = hsc_HUG hsc_env hist' = case mb_brkpt of Nothing -> pure prevHistoryLst Just bi | breakHere False step span -> do - hist1 <- liftIO (mkHistory hsc_env apStack bi) + hist1 <- liftIO (mkHistory hug apStack bi) return $ hist1 `consBL` fromListBL 50 hist | otherwise -> pure prevHistoryLst handleRunStatus step expr bindings final_ids status =<< hist' -setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m () -- #19157 -setupBreakpoint hsc_env bi cnt = do - let modl = bi_tick_mod bi - modBreaks <- liftIO $ readModBreaks hsc_env modl +setupBreakpoint :: GhcMonad m => Interp -> BreakpointId -> Int -> m () -- #19157 +setupBreakpoint interp bi cnt = do + hug <- hsc_HUG <$> getSession + modBreaks <- liftIO $ readModBreaks hug (bi_tick_mod bi) let breakarray = modBreaks_flags modBreaks - interp = hscInterp hsc_env _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt pure () @@ -494,7 +495,7 @@ moveHist fn = do span <- case mb_info of Nothing -> return $ mkGeneralSrcSpan (fsLit "<unknown>") Just ibi -> liftIO $ do - brks <- readModBreaks hsc_env (ibi_tick_mod ibi) + brks <- readModBreaks (hsc_HUG hsc_env) (ibi_tick_mod ibi) return $ modBreaks_locs brks ! ibi_tick_index ibi (hsc_env1, names) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info @@ -525,11 +526,6 @@ moveHist fn = do result_fs :: FastString result_fs = fsLit "_result" --- | Read the 'ModBreaks' of the given home 'Module' from the 'HomeUnitGraph'. -readModBreaks :: HscEnv -> Module -> IO ModBreaks -readModBreaks hsc_env mod = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule mod (hsc_HUG hsc_env) - - bindLocalsAtBreakpoint :: HscEnv -> ForeignHValue @@ -560,8 +556,9 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do - info_brks <- readModBreaks hsc_env (ibi_info_mod ibi) - tick_brks <- readModBreaks hsc_env (ibi_tick_mod ibi) + let hug = hsc_HUG hsc_env + info_brks <- readModBreaks hug (ibi_info_mod ibi) + tick_brks <- readModBreaks hug (ibi_tick_mod ibi) let info = expectJust $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks) interp = hscInterp hsc_env occs = modBreaks_vars tick_brks ! ibi_tick_index ibi ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -27,10 +27,9 @@ module GHC.Runtime.Interpreter , getClosure , whereFrom , getModBreaks + , readModBreaks , seqHValue , evalBreakpointToId - , interpreterDynamic - , interpreterProfiled -- * The object-code linker , initObjLinker @@ -98,7 +97,6 @@ import GHC.Unit.Env #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run -import GHC.Platform.Ways #endif import Control.Concurrent @@ -117,6 +115,7 @@ import qualified GHC.InfoProv as InfoProv import GHC.Builtin.Names import GHC.Types.Name +import qualified GHC.Unit.Home.Graph as HUG -- Standard libraries import GHC.Exts @@ -732,13 +731,12 @@ wormholeRef interp _r = case interpInstance interp of ExternalInterp {} -> throwIO (InstallationError "this operation requires -fno-external-interpreter") --- ----------------------------------------------------------------------------- --- Misc utils - -fromEvalResult :: EvalResult a -> IO a -fromEvalResult (EvalException e) = throwIO (fromSerializableException e) -fromEvalResult (EvalSuccess a) = return a +-------------------------------------------------------------------------------- +-- * Finding breakpoint information +-------------------------------------------------------------------------------- +-- | Get the breakpoint information from the ByteCode object associated to this +-- 'HomeModInfo'. getModBreaks :: HomeModInfo -> Maybe ModBreaks getModBreaks hmi | Just linkable <- homeModInfoByteCode hmi, @@ -748,24 +746,15 @@ getModBreaks hmi | otherwise = Nothing -- probably object code --- | Interpreter uses Profiling way -interpreterProfiled :: Interp -> Bool -interpreterProfiled interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> hostIsProfiled -#endif - ExternalInterp ext -> case ext of - ExtIServ i -> iservConfProfiled (interpConfig i) - ExtJS {} -> False -- we don't support profiling yet in the JS backend - ExtWasm i -> wasmInterpProfiled $ interpConfig i - --- | Interpreter uses Dynamic way -interpreterDynamic :: Interp -> Bool -interpreterDynamic interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> hostIsDynamic -#endif - ExternalInterp ext -> case ext of - ExtIServ i -> iservConfDynamic (interpConfig i) - ExtJS {} -> False -- dynamic doesn't make sense for JS - ExtWasm {} -> True -- wasm dyld can only load dynamic code +-- | Read the 'InternalModBreaks' and 'ModBreaks' of the given home 'Module' +-- from the 'HomeUnitGraph'. +readModBreaks :: HomeUnitGraph -> Module -> IO ModBreaks +readModBreaks hug modl = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule modl hug + +-- ----------------------------------------------------------------------------- +-- Misc utils + +fromEvalResult :: EvalResult a -> IO a +fromEvalResult (EvalException e) = throwIO (fromSerializableException e) +fromEvalResult (EvalSuccess a) = return a + ===================================== compiler/GHC/Runtime/Interpreter/Types.hs ===================================== @@ -24,7 +24,8 @@ module GHC.Runtime.Interpreter.Types , interpSymbolSuffix , eliminateInterpSymbol , interpretedInterpSymbol - + , interpreterProfiled + , interpreterDynamic -- * IServ , IServ @@ -48,6 +49,9 @@ import GHCi.RemoteTypes import GHCi.Message ( Pipe ) import GHC.Platform +#if defined(HAVE_INTERNAL_INTERPRETER) +import GHC.Platform.Ways +#endif import GHC.Utils.TmpFs import GHC.Utils.Logger import GHC.Unit.Env @@ -136,6 +140,28 @@ data ExtInterpInstance c = ExtInterpInstance -- ^ Instance specific extra fields } +-- | Interpreter uses Profiling way +interpreterProfiled :: Interp -> Bool +interpreterProfiled interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsProfiled +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfProfiled (interpConfig i) + ExtJS {} -> False -- we don't support profiling yet in the JS backend + ExtWasm i -> wasmInterpProfiled $ interpConfig i + +-- | Interpreter uses Dynamic way +interpreterDynamic :: Interp -> Bool +interpreterDynamic interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsDynamic +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfDynamic (interpConfig i) + ExtJS {} -> False -- dynamic doesn't make sense for JS + ExtWasm {} -> True -- wasm dyld can only load dynamic code + ------------------------ -- JS Stuff ------------------------ ===================================== compiler/GHC/Stg/BcPrep.hs ===================================== @@ -49,7 +49,7 @@ bcPrepRHS con@StgRhsCon{} = pure con bcPrepExpr :: StgExpr -> BcPrepM StgExpr -- explicitly match all constructors so we get a warning if we miss any -bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _ _) rhs) +bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs) | isLiftedTypeKind (typeKind tick_ty) = do id <- newId tick_ty rhs' <- bcPrepExpr rhs ===================================== compiler/GHC/Stg/FVs.hs ===================================== @@ -257,8 +257,8 @@ exprFVs env = go , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs = (StgTick tick e', imp_fvs, top_fvs, lcl_fvs') where - tickish (Breakpoint _ _ ids _) = mkDVarSet ids - tickish _ = emptyDVarSet + tickish (Breakpoint _ _ ids) = mkDVarSet ids + tickish _ = emptyDVarSet go_bind dc bind body = (dc bind' body', imp_fvs, top_fvs, lcl_fvs) where ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -4,13 +4,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} -- -- (c) The University of Glasgow 2002-2006 -- -- | GHC.StgToByteCode: Generate bytecode from STG -module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where +module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen ) where import GHC.Prelude @@ -33,6 +34,7 @@ import GHC.Platform.Profile import GHC.Runtime.Interpreter import GHCi.FFI import GHC.Types.Basic +import GHC.Types.Breakpoint import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Id @@ -95,6 +97,10 @@ import GHC.Stg.Syntax import qualified Data.IntSet as IntSet import GHC.CoreToIface +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.State (StateT(..)) + -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -119,7 +125,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries flattenBind (StgNonRec b e) = [(b,e)] flattenBind (StgRec bs) = bs - (BcM_State{..}, proto_bcos) <- + (proto_bcos, BcM_State{..}) <- runBc hsc_env this_mod mb_modBreaks $ do let flattened_binds = concatMap flattenBind (reverse lifted_binds) FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds @@ -311,7 +317,7 @@ schemeTopBind (id, rhs) -- because mkConAppCode treats nullary constructor applications -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. - -- ioToBc (putStrLn $ "top level BCO") + -- liftIO (putStrLn $ "top level BCO") pure (mkProtoBCO platform add_bco_name (getName id) (toOL [PACK data_con 0, RETURN P]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) @@ -388,7 +394,7 @@ schemeR_wrk fvs nm original_body (args, body) -- | Introduce break instructions for ticked expressions. -- If no breakpoint information is available, the instruction is omitted. schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList -schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do +schemeER_wrk d p (StgTick (Breakpoint tick_ty (BreakpointId tick_mod tick_no) fvs) rhs) = do code <- schemeE d 0 p rhs hsc_env <- getHscEnv current_mod <- getCurrentModule @@ -448,7 +454,7 @@ break_info hsc_env mod current_mod current_mod_breaks | mod == current_mod = pure current_mod_breaks | otherwise - = ioToBc (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case + = liftIO (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case Just hp -> pure $ getModBreaks hp Nothing -> pure Nothing @@ -640,10 +646,9 @@ schemeE d s p (StgLet _ext binds body) = do thunk_codes <- sequence compile_binds return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) -schemeE _d _s _p (StgTick (Breakpoint _ bp_id _ _) _rhs) - = panic ("schemeE: Breakpoint without let binding: " ++ - show bp_id ++ - " forgot to run bcPrep?") +schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs) + = pprPanic "schemeE: Breakpoint without let binding:" + (ppr bp_id <+> text "forgot to run bcPrep?") -- ignore other kinds of tick schemeE d s p (StgTick _ rhs) = schemeE d s p rhs @@ -2627,63 +2632,38 @@ typeArgReps platform = map (toArgRep platform) . typePrimRep -- ----------------------------------------------------------------------------- -- The bytecode generator's monad +-- | Read only environment for generating ByteCode +data BcM_Env + = BcM_Env + { bcm_hsc_env :: HscEnv + , bcm_module :: Module -- current module (for breakpoints) + } + data BcM_State = BcM_State - { bcm_hsc_env :: HscEnv - , thisModule :: Module -- current module (for breakpoints) - , nextlabel :: Word32 -- for generating local labels - , modBreaks :: Maybe ModBreaks -- info about breakpoints - - , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence. - -- Indexed with breakpoint *info* index. - -- See Note [Breakpoint identifiers] - -- in GHC.Types.Breakpoint - , breakInfoIdx :: !Int -- ^ Next index for breakInfo array + { nextlabel :: !Word32 -- ^ For generating local labels + , breakInfoIdx :: !Int -- ^ Next index for breakInfo array + , modBreaks :: Maybe ModBreaks -- info about breakpoints + + , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence. + -- Indexed with breakpoint *info* index. + -- See Note [Breakpoint identifiers] + -- in GHC.Types.Breakpoint } -newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor) - -ioToBc :: IO a -> BcM a -ioToBc io = BcM $ \st -> do - x <- io - return (st, x) - -runBc :: HscEnv -> Module -> Maybe ModBreaks - -> BcM r - -> IO (BcM_State, r) -runBc hsc_env this_mod modBreaks (BcM m) - = m (BcM_State hsc_env this_mod 0 modBreaks IntMap.empty 0) +newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (r, BcM_State)) + deriving (Functor, Applicative, Monad, MonadIO) + via (ReaderT BcM_Env (StateT BcM_State IO)) -thenBc :: BcM a -> (a -> BcM b) -> BcM b -thenBc (BcM expr) cont = BcM $ \st0 -> do - (st1, q) <- expr st0 - let BcM k = cont q - (st2, r) <- k st1 - return (st2, r) - -thenBc_ :: BcM a -> BcM b -> BcM b -thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do - (st1, _) <- expr st0 - (st2, r) <- cont st1 - return (st2, r) - -returnBc :: a -> BcM a -returnBc result = BcM $ \st -> (return (st, result)) - -instance Applicative BcM where - pure = returnBc - (<*>) = ap - (*>) = thenBc_ - -instance Monad BcM where - (>>=) = thenBc - (>>) = (*>) +runBc :: HscEnv -> Module -> Maybe ModBreaks -> BcM r -> IO (r, BcM_State) +runBc hsc_env this_mod mbs (BcM m) + = m (BcM_Env hsc_env this_mod) (BcM_State 0 0 mbs IntMap.empty) instance HasDynFlags BcM where - getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st)) + getDynFlags = hsc_dflags <$> getHscEnv getHscEnv :: BcM HscEnv -getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) +getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st) getProfile :: BcM Profile getProfile = targetProfile <$> getDynFlags @@ -2696,31 +2676,31 @@ shouldAddBcoName = do else return Nothing getLabelBc :: BcM LocalLabel -getLabelBc - = BcM $ \st -> do let nl = nextlabel st - when (nl == maxBound) $ - panic "getLabelBc: Ran out of labels" - return (st{nextlabel = nl + 1}, LocalLabel nl) +getLabelBc = BcM $ \_ st -> + do let nl = nextlabel st + when (nl == maxBound) $ + panic "getLabelBc: Ran out of labels" + return (LocalLabel nl, st{nextlabel = nl + 1}) getLabelsBc :: Word32 -> BcM [LocalLabel] -getLabelsBc n - = BcM $ \st -> let ctr = nextlabel st - in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1]) +getLabelsBc n = BcM $ \_ st -> + let ctr = nextlabel st + in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n}) newBreakInfo :: CgBreakInfo -> BcM Int -newBreakInfo info = BcM $ \st -> +newBreakInfo info = BcM $ \_ st -> let ix = breakInfoIdx st st' = st - { breakInfo = IntMap.insert ix info (breakInfo st) - , breakInfoIdx = ix + 1 - } - in return (st', ix) + { breakInfo = IntMap.insert ix info (breakInfo st) + , breakInfoIdx = ix + 1 + } + in return (ix, st') getCurrentModule :: BcM Module -getCurrentModule = BcM $ \st -> return (st, thisModule st) +getCurrentModule = BcM $ \env st -> return (bcm_module env, st) getCurrentModBreaks :: BcM (Maybe ModBreaks) -getCurrentModBreaks = BcM $ \st -> return (st, modBreaks st) +getCurrentModBreaks = BcM $ \_env st -> return (modBreaks st, st) tickFS :: FastString tickFS = fsLit "ticked" ===================================== compiler/GHC/Types/Breakpoint.hs ===================================== @@ -8,6 +8,9 @@ where import GHC.Prelude import GHC.Unit.Module +import GHC.Utils.Outputable +import Control.DeepSeq +import Data.Data (Data) -- | Breakpoint identifier. -- @@ -16,7 +19,7 @@ data BreakpointId = BreakpointId { bi_tick_mod :: !Module -- ^ Breakpoint tick module , bi_tick_index :: !Int -- ^ Breakpoint tick index } - deriving (Eq, Ord) + deriving (Eq, Ord, Data) -- | Internal breakpoint identifier -- @@ -53,3 +56,11 @@ toBreakpointId ibi = BreakpointId -- So every breakpoint occurrence gets assigned a module-unique *info index* and -- we store it alongside the occurrence module (*info module*) in the -- InternalBreakpointId datatype. + +instance Outputable BreakpointId where + ppr BreakpointId{bi_tick_mod, bi_tick_index} = + text "BreakpointId" <+> ppr bi_tick_mod <+> ppr bi_tick_index + +instance NFData BreakpointId where + rnf BreakpointId{bi_tick_mod, bi_tick_index} = + rnf bi_tick_mod `seq` rnf bi_tick_index ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Core.Type import GHC.Unit.Module +import GHC.Types.Breakpoint import GHC.Types.CostCentre import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) import GHC.Types.Var @@ -128,7 +129,7 @@ data GenTickish pass = -- and (b) substituting (don't substitute for them) | Breakpoint { breakpointExt :: XBreakpoint pass - , breakpointId :: !Int + , breakpointId :: !BreakpointId , breakpointFVs :: [XTickishId pass] -- ^ the order of this list is important: -- it matches the order of the lists in the @@ -136,7 +137,6 @@ data GenTickish pass = -- -- Careful about substitution! See -- Note [substTickish] in "GHC.Core.Subst". - , breakpointModule :: Module } -- | A source note. ===================================== ghc/GHCi/UI.hs ===================================== @@ -4371,7 +4371,7 @@ getIgnoreCount str = setupBreakpoint :: GhciMonad m => GHC.BreakpointId -> Int -> m() setupBreakpoint loc count = do hsc_env <- GHC.getSession - GHC.setupBreakpoint hsc_env loc count + GHC.setupBreakpoint (hscInterp hsc_env) loc count backCmd :: GhciMonad m => String -> m () backCmd arg View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/461986b7338451fe82ba7dd20b3f12… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/461986b7338451fe82ba7dd20b3f12… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-9] stg2bc: Derive BcM via ReaderT StateT
by Rodrigo Mesquita (＠alt-romes) 30 Jun '25

30 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-9 at Glasgow Haskell Compiler / GHC Commits: 461986b7 by Rodrigo Mesquita at 2025-06-30T19:35:38+01:00 stg2bc: Derive BcM via ReaderT StateT A small refactor that simplifies GHC.StgToByteCode by deriving-via the Monad instances for BcM. This is done along the lines of previous similar refactors like 72b54c0760bbf85be1f73c1a364d4701e5720465. - - - - - 1 changed file: - compiler/GHC/StgToByteCode.hs Changes: ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -4,13 +4,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} -- -- (c) The University of Glasgow 2002-2006 -- -- | GHC.StgToByteCode: Generate bytecode from STG -module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where +module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen ) where import GHC.Prelude @@ -96,6 +97,10 @@ import GHC.Stg.Syntax import qualified Data.IntSet as IntSet import GHC.CoreToIface +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.State (StateT(..)) + -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -120,7 +125,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries flattenBind (StgNonRec b e) = [(b,e)] flattenBind (StgRec bs) = bs - (BcM_State{..}, proto_bcos) <- + (proto_bcos, BcM_State{..}) <- runBc hsc_env this_mod mb_modBreaks $ do let flattened_binds = concatMap flattenBind (reverse lifted_binds) FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds @@ -312,7 +317,7 @@ schemeTopBind (id, rhs) -- because mkConAppCode treats nullary constructor applications -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. - -- ioToBc (putStrLn $ "top level BCO") + -- liftIO (putStrLn $ "top level BCO") pure (mkProtoBCO platform add_bco_name (getName id) (toOL [PACK data_con 0, RETURN P]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) @@ -449,7 +454,7 @@ break_info hsc_env mod current_mod current_mod_breaks | mod == current_mod = pure current_mod_breaks | otherwise - = ioToBc (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case + = liftIO (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case Just hp -> pure $ getModBreaks hp Nothing -> pure Nothing @@ -642,8 +647,8 @@ schemeE d s p (StgLet _ext binds body) = do return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs) - = pprPanic "schemeE: Breakpoint without let binding: " $ - ppr bp_id <> text " forgot to run bcPrep?" + = pprPanic "schemeE: Breakpoint without let binding:" + (ppr bp_id <+> text "forgot to run bcPrep?") -- ignore other kinds of tick schemeE d s p (StgTick _ rhs) = schemeE d s p rhs @@ -2627,63 +2632,38 @@ typeArgReps platform = map (toArgRep platform) . typePrimRep -- ----------------------------------------------------------------------------- -- The bytecode generator's monad +-- | Read only environment for generating ByteCode +data BcM_Env + = BcM_Env + { bcm_hsc_env :: HscEnv + , bcm_module :: Module -- current module (for breakpoints) + } + data BcM_State = BcM_State - { bcm_hsc_env :: HscEnv - , thisModule :: Module -- current module (for breakpoints) - , nextlabel :: Word32 -- for generating local labels - , modBreaks :: Maybe ModBreaks -- info about breakpoints - - , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence. - -- Indexed with breakpoint *info* index. - -- See Note [Breakpoint identifiers] - -- in GHC.Types.Breakpoint - , breakInfoIdx :: !Int -- ^ Next index for breakInfo array + { nextlabel :: !Word32 -- ^ For generating local labels + , breakInfoIdx :: !Int -- ^ Next index for breakInfo array + , modBreaks :: Maybe ModBreaks -- info about breakpoints + + , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence. + -- Indexed with breakpoint *info* index. + -- See Note [Breakpoint identifiers] + -- in GHC.Types.Breakpoint } -newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor) - -ioToBc :: IO a -> BcM a -ioToBc io = BcM $ \st -> do - x <- io - return (st, x) - -runBc :: HscEnv -> Module -> Maybe ModBreaks - -> BcM r - -> IO (BcM_State, r) -runBc hsc_env this_mod modBreaks (BcM m) - = m (BcM_State hsc_env this_mod 0 modBreaks IntMap.empty 0) +newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (r, BcM_State)) + deriving (Functor, Applicative, Monad, MonadIO) + via (ReaderT BcM_Env (StateT BcM_State IO)) -thenBc :: BcM a -> (a -> BcM b) -> BcM b -thenBc (BcM expr) cont = BcM $ \st0 -> do - (st1, q) <- expr st0 - let BcM k = cont q - (st2, r) <- k st1 - return (st2, r) - -thenBc_ :: BcM a -> BcM b -> BcM b -thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do - (st1, _) <- expr st0 - (st2, r) <- cont st1 - return (st2, r) - -returnBc :: a -> BcM a -returnBc result = BcM $ \st -> (return (st, result)) - -instance Applicative BcM where - pure = returnBc - (<*>) = ap - (*>) = thenBc_ - -instance Monad BcM where - (>>=) = thenBc - (>>) = (*>) +runBc :: HscEnv -> Module -> Maybe ModBreaks -> BcM r -> IO (r, BcM_State) +runBc hsc_env this_mod mbs (BcM m) + = m (BcM_Env hsc_env this_mod) (BcM_State 0 0 mbs IntMap.empty) instance HasDynFlags BcM where - getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st)) + getDynFlags = hsc_dflags <$> getHscEnv getHscEnv :: BcM HscEnv -getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) +getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st) getProfile :: BcM Profile getProfile = targetProfile <$> getDynFlags @@ -2696,31 +2676,31 @@ shouldAddBcoName = do else return Nothing getLabelBc :: BcM LocalLabel -getLabelBc - = BcM $ \st -> do let nl = nextlabel st - when (nl == maxBound) $ - panic "getLabelBc: Ran out of labels" - return (st{nextlabel = nl + 1}, LocalLabel nl) +getLabelBc = BcM $ \_ st -> + do let nl = nextlabel st + when (nl == maxBound) $ + panic "getLabelBc: Ran out of labels" + return (LocalLabel nl, st{nextlabel = nl + 1}) getLabelsBc :: Word32 -> BcM [LocalLabel] -getLabelsBc n - = BcM $ \st -> let ctr = nextlabel st - in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1]) +getLabelsBc n = BcM $ \_ st -> + let ctr = nextlabel st + in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n}) newBreakInfo :: CgBreakInfo -> BcM Int -newBreakInfo info = BcM $ \st -> +newBreakInfo info = BcM $ \_ st -> let ix = breakInfoIdx st st' = st - { breakInfo = IntMap.insert ix info (breakInfo st) - , breakInfoIdx = ix + 1 - } - in return (st', ix) + { breakInfo = IntMap.insert ix info (breakInfo st) + , breakInfoIdx = ix + 1 + } + in return (ix, st') getCurrentModule :: BcM Module -getCurrentModule = BcM $ \st -> return (st, thisModule st) +getCurrentModule = BcM $ \env st -> return (bcm_module env, st) getCurrentModBreaks :: BcM (Maybe ModBreaks) -getCurrentModBreaks = BcM $ \st -> return (st, modBreaks st) +getCurrentModBreaks = BcM $ \_env st -> return (modBreaks st, st) tickFS :: FastString tickFS = fsLit "ticked" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/461986b7338451fe82ba7dd20b3f12b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/461986b7338451fe82ba7dd20b3f12b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-9] stg2bc: Derive BcM via ReaderT StateT
by Rodrigo Mesquita (＠alt-romes) 30 Jun '25

30 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-9 at Glasgow Haskell Compiler / GHC Commits: d8aed5c1 by Rodrigo Mesquita at 2025-06-30T19:28:16+01:00 stg2bc: Derive BcM via ReaderT StateT A small refactor that simplifies GHC.StgToByteCode by deriving-via the Monad instances for BcM. This is done along the lines of previous similar refactors like 72b54c0760bbf85be1f73c1a364d4701e5720465. - - - - - 1 changed file: - compiler/GHC/StgToByteCode.hs Changes: ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -4,13 +4,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} -- -- (c) The University of Glasgow 2002-2006 -- -- | GHC.StgToByteCode: Generate bytecode from STG -module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where +module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen ) where import GHC.Prelude @@ -96,6 +97,10 @@ import GHC.Stg.Syntax import qualified Data.IntSet as IntSet import GHC.CoreToIface +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.State (StateT(..)) + -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -120,7 +125,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries flattenBind (StgNonRec b e) = [(b,e)] flattenBind (StgRec bs) = bs - (BcM_State{..}, proto_bcos) <- + (proto_bcos, BcM_State{..}) <- runBc hsc_env this_mod mb_modBreaks $ do let flattened_binds = concatMap flattenBind (reverse lifted_binds) FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds @@ -312,7 +317,7 @@ schemeTopBind (id, rhs) -- because mkConAppCode treats nullary constructor applications -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. - -- ioToBc (putStrLn $ "top level BCO") + -- liftIO (putStrLn $ "top level BCO") pure (mkProtoBCO platform add_bco_name (getName id) (toOL [PACK data_con 0, RETURN P]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) @@ -642,8 +647,8 @@ schemeE d s p (StgLet _ext binds body) = do return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs) - = pprPanic "schemeE: Breakpoint without let binding: " $ - ppr bp_id <> text " forgot to run bcPrep?" + = pprPanic "schemeE: Breakpoint without let binding:" + (ppr bp_id <+> text "forgot to run bcPrep?") -- ignore other kinds of tick schemeE d s p (StgTick _ rhs) = schemeE d s p rhs @@ -2627,63 +2632,38 @@ typeArgReps platform = map (toArgRep platform) . typePrimRep -- ----------------------------------------------------------------------------- -- The bytecode generator's monad +-- | Read only environment for generating ByteCode +data BcM_Env + = BcM_Env + { bcm_hsc_env :: HscEnv + , bcm_module :: Module -- current module (for breakpoints) + } + data BcM_State = BcM_State - { bcm_hsc_env :: HscEnv - , thisModule :: Module -- current module (for breakpoints) - , nextlabel :: Word32 -- for generating local labels - , modBreaks :: Maybe ModBreaks -- info about breakpoints - - , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence. - -- Indexed with breakpoint *info* index. - -- See Note [Breakpoint identifiers] - -- in GHC.Types.Breakpoint - , breakInfoIdx :: !Int -- ^ Next index for breakInfo array + { nextlabel :: !Word32 -- ^ For generating local labels + , breakInfoIdx :: !Int -- ^ Next index for breakInfo array + , modBreaks :: Maybe ModBreaks -- info about breakpoints + + , breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence. + -- Indexed with breakpoint *info* index. + -- See Note [Breakpoint identifiers] + -- in GHC.Types.Breakpoint } -newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor) - -ioToBc :: IO a -> BcM a -ioToBc io = BcM $ \st -> do - x <- io - return (st, x) - -runBc :: HscEnv -> Module -> Maybe ModBreaks - -> BcM r - -> IO (BcM_State, r) -runBc hsc_env this_mod modBreaks (BcM m) - = m (BcM_State hsc_env this_mod 0 modBreaks IntMap.empty 0) - -thenBc :: BcM a -> (a -> BcM b) -> BcM b -thenBc (BcM expr) cont = BcM $ \st0 -> do - (st1, q) <- expr st0 - let BcM k = cont q - (st2, r) <- k st1 - return (st2, r) +newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (r, BcM_State)) + deriving (Functor, Applicative, Monad, MonadIO) + via (ReaderT BcM_Env (StateT BcM_State IO)) -thenBc_ :: BcM a -> BcM b -> BcM b -thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do - (st1, _) <- expr st0 - (st2, r) <- cont st1 - return (st2, r) - -returnBc :: a -> BcM a -returnBc result = BcM $ \st -> (return (st, result)) - -instance Applicative BcM where - pure = returnBc - (<*>) = ap - (*>) = thenBc_ - -instance Monad BcM where - (>>=) = thenBc - (>>) = (*>) +runBc :: HscEnv -> Module -> Maybe ModBreaks -> BcM r -> IO (r, BcM_State) +runBc hsc_env this_mod mbs (BcM m) + = m (BcM_Env hsc_env this_mod) (BcM_State 0 0 (mkInternalModBreaks this_mod mbs)) instance HasDynFlags BcM where - getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st)) + getDynFlags = hsc_dflags <$> getHscEnv getHscEnv :: BcM HscEnv -getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) +getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st) getProfile :: BcM Profile getProfile = targetProfile <$> getDynFlags @@ -2696,31 +2676,29 @@ shouldAddBcoName = do else return Nothing getLabelBc :: BcM LocalLabel -getLabelBc - = BcM $ \st -> do let nl = nextlabel st - when (nl == maxBound) $ - panic "getLabelBc: Ran out of labels" - return (st{nextlabel = nl + 1}, LocalLabel nl) +getLabelBc = BcM $ \_ st -> + do let nl = nextlabel st + when (nl == maxBound) $ + panic "getLabelBc: Ran out of labels" + return (LocalLabel nl, st{nextlabel = nl + 1}) getLabelsBc :: Word32 -> BcM [LocalLabel] -getLabelsBc n - = BcM $ \st -> let ctr = nextlabel st - in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1]) +getLabelsBc n = BcM $ \_ st -> + let ctr = nextlabel st + in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n}) -newBreakInfo :: CgBreakInfo -> BcM Int -newBreakInfo info = BcM $ \st -> +newBreakInfo :: CgBreakInfo -> BcM InternalBreakpointId +newBreakInfo info = BcM $ \env st -> let ix = breakInfoIdx st + ibi = InternalBreakpointId (bcm_module env) ix st' = st - { breakInfo = IntMap.insert ix info (breakInfo st) - , breakInfoIdx = ix + 1 - } - in return (st', ix) + { internalBreaks = addInternalBreak ibi info (internalBreaks st) + , breakInfoIdx = ix + 1 + } + in return (ibi, st') getCurrentModule :: BcM Module -getCurrentModule = BcM $ \st -> return (st, thisModule st) - -getCurrentModBreaks :: BcM (Maybe ModBreaks) -getCurrentModBreaks = BcM $ \st -> return (st, modBreaks st) +getCurrentModule = BcM $ \env st -> return (bcm_module env, st) tickFS :: FastString tickFS = fsLit "ticked" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8aed5c15da2fa0c7bdd3251be3829d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8aed5c15da2fa0c7bdd3251be3829d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-9] 6 commits: refactor: "Inspecting the session" moved from GHC
by Rodrigo Mesquita (＠alt-romes) 30 Jun '25

30 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-9 at Glasgow Haskell Compiler / GHC Commits: 5989a722 by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 refactor: "Inspecting the session" moved from GHC Moved utilities for inspecting the session from the GHC module to GHC.Driver.Session.Inspect Purely a clean up - - - - - ff7d68ab by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Pass the HUG to readModBreaks, not HscEnv A minor cleanup. The associated history and setupBreakpoint functions are changed accordingly. - - - - - cc8a6cd8 by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Move readModBreaks to GHC.Runtime.Interpreter With some small docs changes - - - - - 56218cbf by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Move interpreterProfiled to Interp.Types Moves interpreterProfiled and interpreterDynamic to GHC.Runtime.Interpreter.Types from GHC.Runtime.Interpreter. - - - - - e60ece5d by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Don't import GHC in Debugger.Breakpoints Remove the top-level import GHC from GHC.Runtime.Debugger.Breakpoints This makes the module dependencies more granular and cleans up the qualified imports from the code. - - - - - de60ae45 by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 refactor: Use BreakpointId in Core and Ifaces - - - - - 28 changed files: - compiler/GHC.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - + compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/FVs.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Types/Breakpoint.hs - compiler/GHC/Types/Tickish.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC.hs ===================================== @@ -346,6 +346,7 @@ import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.CmdLine import GHC.Driver.Session +import GHC.Driver.Session.Inspect import GHC.Driver.Backend import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) @@ -378,7 +379,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails) +import GHC.Rename.Names (renamePkgQual, renameRawPkgQual) import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types @@ -425,14 +426,12 @@ import GHC.Types.Target import GHC.Types.Basic import GHC.Types.TyThing import GHC.Types.Name.Env -import GHC.Types.Name.Ppr import GHC.Types.TypeEnv import GHC.Types.Breakpoint import GHC.Types.PkgQual import GHC.Unit import GHC.Unit.Env as UnitEnv -import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModGuts @@ -1570,169 +1569,6 @@ compileCore simplify fn = do cm_safe = safe_mode } --- %************************************************************************ --- %* * --- Inspecting the session --- %* * --- %************************************************************************ - --- | Get the module dependency graph. -getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary -getModuleGraph = liftM hsc_mod_graph getSession - -{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-} --- | Return @True@ \<==> module is loaded. -isLoaded :: GhcMonad m => ModuleName -> m Bool -isLoaded m = withSession $ \hsc_env -> liftIO $ do - hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m - return $! not (null hmis) - --- | Check whether a 'ModuleName' is found in the 'HomePackageTable' --- for the given 'UnitId'. -isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool -isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do - hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m - return $! isJust hmi - --- | Check whether 'Module' is part of the 'HomeUnitGraph'. --- --- Similar to 'isLoadedModule', but for 'Module's. -isLoadedHomeModule :: GhcMonad m => Module -> m Bool -isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do - hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env) - return $! isJust hmi - --- | Return the bindings for the current interactive session. -getBindings :: GhcMonad m => m [TyThing] -getBindings = withSession $ \hsc_env -> - return $ icInScopeTTs $ hsc_IC hsc_env - --- | Return the instances for the current interactive session. -getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) -getInsts = withSession $ \hsc_env -> - let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env) - in return (instEnvElts inst_env, fam_env) - -getNamePprCtx :: GhcMonad m => m NamePprCtx -getNamePprCtx = withSession $ \hsc_env -> do - return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env) - --- | Container for information about a 'Module'. -data ModuleInfo = ModuleInfo { - minf_type_env :: TypeEnv, - minf_exports :: [AvailInfo], - minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface, - minf_safe :: SafeHaskellMode, - minf_modBreaks :: Maybe ModBreaks - } - -- We don't want HomeModInfo here, because a ModuleInfo applies - -- to package modules too. - - --- | Request information about a loaded 'Module' -getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X -getModuleInfo mdl = withSession $ \hsc_env -> do - if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env) - then liftIO $ getHomeModuleInfo hsc_env mdl - else liftIO $ getPackageModuleInfo hsc_env mdl - -getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getPackageModuleInfo hsc_env mdl - = do eps <- hscEPS hsc_env - iface <- hscGetModuleInterface hsc_env mdl - let - avails = mi_exports iface - pte = eps_PTE eps - tys = [ ty | name <- concatMap availNames avails, - Just ty <- [lookupTypeEnv pte name] ] - - return (Just (ModuleInfo { - minf_type_env = mkTypeEnv tys, - minf_exports = avails, - minf_instances = error "getModuleInfo: instances for package module unimplemented", - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface, - minf_modBreaks = Nothing - })) - -availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv -availsToGlobalRdrEnv hsc_env mod avails - = forceGlobalRdrEnv rdr_env - -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. - where - rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails) - -- We're building a GlobalRdrEnv as if the user imported - -- all the specified modules into the global interactive module - imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} - decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, - is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual, - is_dloc = srcLocSpan interactiveSrcLoc, - is_level = NormalLevel } - -getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getHomeModuleInfo hsc_env mdl = - HUG.lookupHugByModule mdl (hsc_HUG hsc_env) >>= \case - Nothing -> return Nothing - Just hmi -> do - let details = hm_details hmi - iface = hm_iface hmi - return (Just (ModuleInfo { - minf_type_env = md_types details, - minf_exports = md_exports details, - -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo. - minf_instances = instEnvElts $ md_insts details, - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface - ,minf_modBreaks = getModBreaks hmi - })) - --- | The list of top-level entities defined in a module -modInfoTyThings :: ModuleInfo -> [TyThing] -modInfoTyThings minf = typeEnvElts (minf_type_env minf) - -modInfoExports :: ModuleInfo -> [Name] -modInfoExports minf = concatMap availNames $! minf_exports minf - -modInfoExportsWithSelectors :: ModuleInfo -> [Name] -modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf - --- | Returns the instances defined by the specified module. --- Warning: currently unimplemented for package modules. -modInfoInstances :: ModuleInfo -> [ClsInst] -modInfoInstances = minf_instances - -modInfoIsExportedName :: ModuleInfo -> Name -> Bool -modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) - -mkNamePprCtxForModule :: - GhcMonad m => - Module -> - ModuleInfo -> - m NamePprCtx -mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) - ptc = initPromotionTickContext (hsc_dflags hsc_env) - return name_ppr_ctx - -modInfoLookupName :: GhcMonad m => - ModuleInfo -> Name - -> m (Maybe TyThing) -- XXX: returns a Maybe X -modInfoLookupName minf name = withSession $ \hsc_env -> do - case lookupTypeEnv (minf_type_env minf) name of - Just tyThing -> return (Just tyThing) - Nothing -> liftIO (lookupType hsc_env name) - -modInfoIface :: ModuleInfo -> Maybe ModIface -modInfoIface = minf_iface - --- | Retrieve module safe haskell mode -modInfoSafe :: ModuleInfo -> SafeHaskellMode -modInfoSafe = minf_safe - -modInfoModBreaks :: ModuleInfo -> Maybe ModBreaks -modInfoModBreaks = minf_modBreaks - isDictonaryId :: Id -> Bool isDictonaryId id = isDictTy (idType id) @@ -2063,7 +1899,7 @@ getGHCiMonad :: GhcMonad m => m Name getGHCiMonad = fmap (ic_monad . hsc_IC) getSession getHistorySpan :: GhcMonad m => History -> m SrcSpan -getHistorySpan h = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.getHistorySpan hsc_env h +getHistorySpan h = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.getHistorySpan (hsc_HUG hsc_env) h obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term obtainTermFromVal bound force ty a = withSession $ \hsc_env -> ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -287,7 +287,7 @@ exprs_fvs :: [CoreExpr] -> FV exprs_fvs exprs = mapUnionFV expr_fvs exprs tickish_fvs :: CoreTickish -> FV -tickish_fvs (Breakpoint _ _ ids _) = FV.mkFVs ids +tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids tickish_fvs _ = emptyFV {- ********************************************************************** @@ -759,8 +759,8 @@ freeVars = go , AnnTick tickish expr2 ) where expr2 = go expr - tickishFVs (Breakpoint _ _ ids _) = mkDVarSet ids - tickishFVs _ = emptyDVarSet + tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids + tickishFVs _ = emptyDVarSet go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -897,8 +897,8 @@ lintCoreExpr (Cast expr co) lintCoreExpr (Tick tickish expr) = do { case tickish of - Breakpoint _ _ ids _ -> forM_ ids $ \id -> lintIdOcc id 0 - _ -> return () + Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0 + _ -> return () ; markAllJoinsBadIf block_joins $ lintCoreExpr expr } where block_joins = not (tickish `tickishScopesLike` SoftScope) ===================================== compiler/GHC/Core/Map/Expr.hs ===================================== @@ -198,11 +198,10 @@ eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where eqDeBruijnTickish :: DeBruijn CoreTickish -> DeBruijn CoreTickish -> Bool eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where - go (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod) + go (Breakpoint lext lid lids) (Breakpoint rext rid rids) = lid == rid && D env1 lids == D env2 rids && lext == rext - && lmod == rmod go l r = l == r -- Compares for equality, modulo alpha ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2501,7 +2501,7 @@ occAnal env (Tick tickish body) -- For a non-soft tick scope, we can inline lambdas only, so we -- abandon tail calls, and do markAllInsideLam too: usage_lam - | Breakpoint _ _ ids _ <- tickish + | Breakpoint _ _ ids <- tickish = -- Never substitute for any of the Ids in a Breakpoint addManyOccs usage_lam (mkVarSet ids) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1461,8 +1461,8 @@ simplTick env tickish expr cont simplTickish env tickish - | Breakpoint ext n ids modl <- tickish - = Breakpoint ext n (mapMaybe (getDoneId . substId env) ids) modl + | Breakpoint ext bid ids <- tickish + = Breakpoint ext bid (mapMaybe (getDoneId . substId env) ids) | otherwise = tickish -- Push type application and coercion inside a tick ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Prelude import GHC.Core import GHC.Core.Stats (exprStats) +import GHC.Types.Breakpoint import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Literal( pprLiteral ) import GHC.Types.Name( pprInfixName, pprPrefixName ) @@ -694,10 +695,10 @@ instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where ppr modl, comma, ppr ix, text ">"] - ppr (Breakpoint _ext ix vars modl) = + ppr (Breakpoint _ext bid vars) = hcat [text "break<", - ppr modl, comma, - ppr ix, + ppr (bi_tick_mod bid), comma, + ppr (bi_tick_index bid), text ">", parens (hcat (punctuate comma (map ppr vars)))] ppr (ProfNote { profNoteCC = cc, ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -602,8 +602,8 @@ substDVarSet subst@(Subst _ _ tv_env cv_env) fvs ------------------ -- | Drop free vars from the breakpoint if they have a non-variable substitution. substTickish :: Subst -> CoreTickish -> CoreTickish -substTickish subst (Breakpoint ext n ids modl) - = Breakpoint ext n (mapMaybe do_one ids) modl +substTickish subst (Breakpoint ext bid ids) + = Breakpoint ext bid (mapMaybe do_one ids) where do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst ===================================== compiler/GHC/Core/Tidy.hs ===================================== @@ -235,8 +235,8 @@ tidyAlt env (Alt con vs rhs) ------------ Tickish -------------- tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish -tidyTickish env (Breakpoint ext ix ids modl) - = Breakpoint ext ix (map (tidyVarOcc env) ids) modl +tidyTickish env (Breakpoint ext bid ids) + = Breakpoint ext bid (map (tidyVarOcc env) ids) tidyTickish _ other_tickish = other_tickish ------------ Rules -------------- ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -2492,11 +2492,10 @@ cheapEqExpr' ignoreTick e1 e2 -- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool -eqTickish env (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod) +eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids) = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids && - lext == rext && - lmod == rmod + lext == rext eqTickish _ l r = l == r -- | Finds differences between core bindings, see @diffExpr@. ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -586,8 +586,8 @@ toIfaceTickish (ProfNote cc tick push) = IfaceSCC cc tick push toIfaceTickish (HpcTick modl ix) = IfaceHpcTick modl ix toIfaceTickish (SourceNote src (LexicalFastString names)) = IfaceSource src names -toIfaceTickish (Breakpoint _ ix fv m) = - IfaceBreakpoint ix (toIfaceVar <$> fv) m +toIfaceTickish (Breakpoint _ ix fv) = + IfaceBreakpoint ix (toIfaceVar <$> fv) --------------------- toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -643,10 +643,10 @@ coreToStgArgs (arg : args) = do -- Non-type argument coreToStgTick :: Type -- type of the ticked expression -> CoreTickish -> StgTickish -coreToStgTick _ty (HpcTick m i) = HpcTick m i -coreToStgTick _ty (SourceNote span nm) = SourceNote span nm -coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope -coreToStgTick !ty (Breakpoint _ bid fvs modl) = Breakpoint ty bid fvs modl +coreToStgTick _ty (HpcTick m i) = HpcTick m i +coreToStgTick _ty (SourceNote span nm) = SourceNote span nm +coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope +coreToStgTick !ty (Breakpoint _ bid fvs) = Breakpoint ty bid fvs -- --------------------------------------------------------------------------- -- The magic for lets: ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -842,9 +842,9 @@ cpeRhsE env (Tick tickish expr) = do { body <- cpeBodyNF env expr ; return (emptyFloats, mkTick tickish' body) } where - tickish' | Breakpoint ext n fvs modl <- tickish + tickish' | Breakpoint ext bid fvs <- tickish -- See also 'substTickish' - = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) modl + = Breakpoint ext bid (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) | otherwise = tickish ===================================== compiler/GHC/Driver/Session/Inspect.hs ===================================== @@ -0,0 +1,201 @@ +{-# LANGUAGE LambdaCase #-} + +-- | GHC API utilities for inspecting the GHC session +module GHC.Driver.Session.Inspect where + +import GHC.Prelude +import GHC.Data.Maybe +import Control.Monad + +import GHC.ByteCode.Types +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv +import GHC.Driver.Env +import GHC.Driver.Main +import GHC.Driver.Monad +import GHC.Driver.Session +import GHC.Rename.Names +import GHC.Runtime.Context +import GHC.Runtime.Interpreter +import GHC.Types.Avail +import GHC.Types.Name +import GHC.Types.Name.Ppr +import GHC.Types.Name.Reader +import GHC.Types.Name.Set +import GHC.Types.PkgQual +import GHC.Types.SafeHaskell +import GHC.Types.SrcLoc +import GHC.Types.TyThing +import GHC.Types.TypeEnv +import GHC.Unit.External +import GHC.Unit.Home.ModInfo +import GHC.Unit.Module +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Utils.Misc +import GHC.Utils.Outputable +import qualified GHC.Unit.Home.Graph as HUG + +-- %************************************************************************ +-- %* * +-- Inspecting the session +-- %* * +-- %************************************************************************ + +-- | Get the module dependency graph. +getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary +getModuleGraph = liftM hsc_mod_graph getSession + +{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-} +-- | Return @True@ \<==> module is loaded. +isLoaded :: GhcMonad m => ModuleName -> m Bool +isLoaded m = withSession $ \hsc_env -> liftIO $ do + hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m + return $! not (null hmis) + +-- | Check whether a 'ModuleName' is found in the 'HomePackageTable' +-- for the given 'UnitId'. +isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool +isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do + hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m + return $! isJust hmi + +-- | Check whether 'Module' is part of the 'HomeUnitGraph'. +-- +-- Similar to 'isLoadedModule', but for 'Module's. +isLoadedHomeModule :: GhcMonad m => Module -> m Bool +isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do + hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env) + return $! isJust hmi + +-- | Return the bindings for the current interactive session. +getBindings :: GhcMonad m => m [TyThing] +getBindings = withSession $ \hsc_env -> + return $ icInScopeTTs $ hsc_IC hsc_env + +-- | Return the instances for the current interactive session. +getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) +getInsts = withSession $ \hsc_env -> + let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env) + in return (instEnvElts inst_env, fam_env) + +getNamePprCtx :: GhcMonad m => m NamePprCtx +getNamePprCtx = withSession $ \hsc_env -> do + return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env) + +-- | Container for information about a 'Module'. +data ModuleInfo = ModuleInfo { + minf_type_env :: TypeEnv, + minf_exports :: [AvailInfo], + minf_instances :: [ClsInst], + minf_iface :: Maybe ModIface, + minf_safe :: SafeHaskellMode, + minf_modBreaks :: Maybe ModBreaks + } + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X +getModuleInfo mdl = withSession $ \hsc_env -> do + if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env) + then liftIO $ getHomeModuleInfo hsc_env mdl + else liftIO $ getPackageModuleInfo hsc_env mdl + +getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getPackageModuleInfo hsc_env mdl + = do eps <- hscEPS hsc_env + iface <- hscGetModuleInterface hsc_env mdl + let + avails = mi_exports iface + pte = eps_PTE eps + tys = [ ty | name <- concatMap availNames avails, + Just ty <- [lookupTypeEnv pte name] ] + + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = avails, + minf_instances = error "getModuleInfo: instances for package module unimplemented", + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, + minf_modBreaks = Nothing + })) + +availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv +availsToGlobalRdrEnv hsc_env mod avails + = forceGlobalRdrEnv rdr_env + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + where + rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails) + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} + decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, + is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual, + is_dloc = srcLocSpan interactiveSrcLoc, + is_level = NormalLevel } + +getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getHomeModuleInfo hsc_env mdl = + HUG.lookupHugByModule mdl (hsc_HUG hsc_env) >>= \case + Nothing -> return Nothing + Just hmi -> do + let details = hm_details hmi + iface = hm_iface hmi + return (Just (ModuleInfo { + minf_type_env = md_types details, + minf_exports = md_exports details, + -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo. + minf_instances = instEnvElts $ md_insts details, + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, + minf_modBreaks = getModBreaks hmi + })) + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings minf = typeEnvElts (minf_type_env minf) + +modInfoExports :: ModuleInfo -> [Name] +modInfoExports minf = concatMap availNames $! minf_exports minf + +modInfoExportsWithSelectors :: ModuleInfo -> [Name] +modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf + +-- | Returns the instances defined by the specified module. +-- Warning: currently unimplemented for package modules. +modInfoInstances :: ModuleInfo -> [ClsInst] +modInfoInstances = minf_instances + +modInfoIsExportedName :: ModuleInfo -> Name -> Bool +modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) + +mkNamePprCtxForModule :: + GhcMonad m => + Module -> + ModuleInfo -> + m NamePprCtx +mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) + ptc = initPromotionTickContext (hsc_dflags hsc_env) + return name_ppr_ctx + +modInfoLookupName :: GhcMonad m => + ModuleInfo -> Name + -> m (Maybe TyThing) -- XXX: returns a Maybe X +modInfoLookupName minf name = withSession $ \hsc_env -> do + case lookupTypeEnv (minf_type_env minf) name of + Just tyThing -> return (Just tyThing) + Nothing -> liftIO (lookupType hsc_env name) + +modInfoIface :: ModuleInfo -> Maybe ModIface +modInfoIface = minf_iface + +-- | Retrieve module safe haskell mode +modInfoSafe :: ModuleInfo -> SafeHaskellMode +modInfoSafe = minf_safe + +modInfoModBreaks :: ModuleInfo -> Maybe ModBreaks +modInfoModBreaks = minf_modBreaks + ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Driver.Flags (DumpFlag(..)) import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Logger +import GHC.Types.Breakpoint import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Id @@ -1235,7 +1236,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do Breakpoints -> do i <- addMixEntry me - pure (Breakpoint noExtField i ids (this_mod env)) + pure (Breakpoint noExtField (BreakpointId (this_mod env) i) ids) SourceNotes | RealSrcSpan pos' _ <- pos -> return $ SourceNote pos' $ LexicalFastString cc_name ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -56,6 +56,7 @@ import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue) import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey, constraintKindTyConKey ) +import GHC.Types.Breakpoint import GHC.Types.Unique ( hasKey ) import GHC.Iface.Type import GHC.Iface.Recomp.Binary @@ -699,7 +700,7 @@ data IfaceTickish = IfaceHpcTick Module Int -- from HpcTick x | IfaceSCC CostCentre Bool Bool -- from ProfNote | IfaceSource RealSrcSpan FastString -- from SourceNote - | IfaceBreakpoint Int [IfaceExpr] Module -- from Breakpoint + | IfaceBreakpoint BreakpointId [IfaceExpr] -- from Breakpoint data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr -- Note: IfLclName, not IfaceBndr (and same with the case binder) @@ -1848,7 +1849,7 @@ pprIfaceTickish (IfaceSCC cc tick scope) = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) pprIfaceTickish (IfaceSource src _names) = braces (pprUserRealSpan True src) -pprIfaceTickish (IfaceBreakpoint m ix fvs) +pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs) = braces (text "break" <+> ppr m <+> ppr ix <+> ppr fvs) ------------------ @@ -2198,7 +2199,7 @@ freeNamesIfaceTyConParent (IfDataInstance ax tc tys) = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys freeNamesIfTickish :: IfaceTickish -> NameSet -freeNamesIfTickish (IfaceBreakpoint _ fvs _) = +freeNamesIfTickish (IfaceBreakpoint _ fvs) = fnList freeNamesIfExpr fvs freeNamesIfTickish _ = emptyNameSet @@ -2919,7 +2920,7 @@ instance Binary IfaceTickish where put_ bh (srcSpanEndLine src) put_ bh (srcSpanEndCol src) put_ bh name - put_ bh (IfaceBreakpoint m ix fvs) = do + put_ bh (IfaceBreakpoint (BreakpointId m ix) fvs) = do putByte bh 3 put_ bh m put_ bh ix @@ -2947,7 +2948,7 @@ instance Binary IfaceTickish where 3 -> do m <- get bh ix <- get bh fvs <- get bh - return (IfaceBreakpoint m ix fvs) + return (IfaceBreakpoint (BreakpointId m ix) fvs) _ -> panic ("get IfaceTickish " ++ show h) instance Binary IfaceConAlt where @@ -3206,7 +3207,7 @@ instance NFData IfaceTickish where IfaceHpcTick m i -> rnf m `seq` rnf i IfaceSCC cc b1 b2 -> rnf cc `seq` rnf b1 `seq` rnf b2 IfaceSource src str -> rnf src `seq` rnf str - IfaceBreakpoint m i fvs -> rnf m `seq` rnf i `seq` rnf fvs + IfaceBreakpoint i fvs -> rnf i `seq` rnf fvs instance NFData IfaceConAlt where rnf = \case ===================================== compiler/GHC/Iface/Tidy.hs ===================================== @@ -955,7 +955,7 @@ dffvExpr :: CoreExpr -> DFFV () dffvExpr (Var v) = insert v dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 dffvExpr (Lam v e) = extendScope v (dffvExpr e) -dffvExpr (Tick (Breakpoint _ _ ids _) e) = mapM_ insert ids >> dffvExpr e +dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e dffvExpr (Tick _other e) = dffvExpr e dffvExpr (Cast e _) = dffvExpr e dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -1732,9 +1732,9 @@ tcIfaceTickish :: IfaceTickish -> IfL CoreTickish tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) tcIfaceTickish (IfaceSource src name) = return (SourceNote src (LexicalFastString name)) -tcIfaceTickish (IfaceBreakpoint ix fvs modl) = do +tcIfaceTickish (IfaceBreakpoint bid fvs) = do fvs' <- mapM tcIfaceExpr fvs - return (Breakpoint NoExtField ix [f | Var f <- fvs'] modl) + return (Breakpoint NoExtField bid [f | Var f <- fvs']) ------------------------- tcIfaceLit :: Literal -> IfL Literal ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -1,9 +1,12 @@ + -- | GHC API debugger module for finding and setting breakpoints. -- -- This module is user facing and is at least used by `GHCi` and `ghc-debugger` -- to find and set breakpoints. module GHC.Runtime.Debugger.Breakpoints where +import GHC.Prelude + import Control.Monad.Catch import Control.Monad import Data.Array @@ -13,10 +16,18 @@ import Data.Maybe import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as S -import GHC -import GHC.Prelude +import GHC.ByteCode.Types (BreakIndex, ModBreaks(..)) +import GHC.Driver.Env +import GHC.Driver.Monad +import GHC.Driver.Session.Inspect +import GHC.Runtime.Eval import GHC.Runtime.Eval.Utils +import GHC.Types.Name import GHC.Types.SrcLoc +import GHC.Types.Breakpoint +import GHC.Unit.Module +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModSummary import GHC.Utils.Outputable import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict @@ -44,10 +55,10 @@ findBreakByLine line arr ticks = arr ! line starts_here = [ (ix,pan) | (ix, pan) <- ticks, - GHC.srcSpanStartLine pan == line ] + srcSpanStartLine pan == line ] (comp, incomp) = partition ends_here starts_here - where ends_here (_,pan) = GHC.srcSpanEndLine pan == line + where ends_here (_,pan) = srcSpanEndLine pan == line -- | Find a breakpoint in the 'TickArray' of a module, given a line number and a column coordinate. findBreakByCoord :: (Int, Int) -> TickArray -> Maybe (BreakIndex, RealSrcSpan) @@ -63,8 +74,8 @@ findBreakByCoord (line, col) arr contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col) ] after_here = [ tick | tick@(_,pan) <- ticks, - GHC.srcSpanStartLine pan == line, - GHC.srcSpanStartCol pan >= col ] + srcSpanStartLine pan == line, + srcSpanStartCol pan >= col ] leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd @@ -112,7 +123,7 @@ resolveFunctionBreakpoint inp = do Nothing -> do -- No errors found, go and return the module info let mod = fromMaybe (panic "resolveFunctionBreakpoint") mb_mod - mb_mod_info <- GHC.getModuleInfo mod + mb_mod_info <- getModuleInfo mod case mb_mod_info of Nothing -> pure . Left $ text "Could not find ModuleInfo of " <> ppr mod @@ -120,16 +131,16 @@ resolveFunctionBreakpoint inp = do where -- Try to lookup the module for an identifier that is in scope. -- `parseName` throws an exception, if the identifier is not in scope - lookupModuleInscope :: GHC.GhcMonad m => String -> m (Maybe Module) + lookupModuleInscope :: GhcMonad m => String -> m (Maybe Module) lookupModuleInscope mod_top_lvl = do - names <- GHC.parseName mod_top_lvl - pure $ Just $ NE.head $ GHC.nameModule <$> names + names <- parseName mod_top_lvl + pure $ Just $ NE.head $ nameModule <$> names -- Lookup the Module of a module name in the module graph - lookupModuleInGraph :: GHC.GhcMonad m => String -> m (Maybe Module) + lookupModuleInGraph :: GhcMonad m => String -> m (Maybe Module) lookupModuleInGraph mod_str = do - graph <- GHC.getModuleGraph - let hmods = ms_mod <$> GHC.mgModSummaries graph + graph <- getModuleGraph + let hmods = ms_mod <$> mgModSummaries graph pure $ find ((== mod_str) . moduleNameString . moduleName) hmods -- Check validity of an identifier to set a breakpoint: @@ -137,21 +148,21 @@ resolveFunctionBreakpoint inp = do -- 2. the identifier must be in an interpreted module -- 3. the ModBreaks array for module `mod` must have an entry -- for the function - validateBP :: GHC.GhcMonad m => String -> String -> Maybe Module + validateBP :: GhcMonad m => String -> String -> Maybe Module -> m (Maybe SDoc) validateBP mod_str fun_str Nothing = pure $ Just $ quotes (text (combineModIdent mod_str (takeWhile (/= '.') fun_str))) <+> text "not in scope" validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing" validateBP _ fun_str (Just modl) = do - isInterpr <- GHC.moduleIsInterpreted modl + isInterpr <- moduleIsInterpreted modl mb_err_msg <- case isInterpr of False -> pure $ Just $ text "Module" <+> quotes (ppr modl) <+> text "is not interpreted" True -> do mb_modbreaks <- getModBreak modl let found = case mb_modbreaks of Nothing -> False - Just mb -> fun_str `elem` (intercalate "." <$> elems (GHC.modBreaks_decls mb)) + Just mb -> fun_str `elem` (intercalate "." <$> elems (modBreaks_decls mb)) if found then pure Nothing else pure $ Just $ text "No breakpoint found for" <+> quotes (text fun_str) @@ -163,13 +174,13 @@ resolveFunctionBreakpoint inp = do -- for -- (a) this binder only (it maybe a top-level or a nested declaration) -- (b) that do not have an enclosing breakpoint -findBreakForBind :: String {-^ Name of bind to break at -} -> GHC.ModBreaks -> [(BreakIndex, RealSrcSpan)] +findBreakForBind :: String {-^ Name of bind to break at -} -> ModBreaks -> [(BreakIndex, RealSrcSpan)] findBreakForBind str_name modbreaks = filter (not . enclosed) ticks where ticks = [ (index, span) - | (index, decls) <- assocs (GHC.modBreaks_decls modbreaks), + | (index, decls) <- assocs (modBreaks_decls modbreaks), str_name == intercalate "." decls, - RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ] + RealSrcSpan span _ <- [modBreaks_locs modbreaks ! index] ] enclosed (_,sp0) = any subspan ticks where subspan (_,sp) = sp /= sp0 && realSrcSpanStart sp <= realSrcSpanStart sp0 && @@ -180,53 +191,53 @@ findBreakForBind str_name modbreaks = filter (not . enclosed) ticks -------------------------------------------------------------------------------- -- | Maps line numbers to the breakpoint ticks existing at that line for a module. -type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)] +type TickArray = Array Int [(BreakIndex,RealSrcSpan)] -- | Construct the 'TickArray' for the given module. makeModuleLineMap :: GhcMonad m => Module -> m (Maybe TickArray) makeModuleLineMap m = do - mi <- GHC.getModuleInfo m - return $ mkTickArray . assocs . GHC.modBreaks_locs <$> (GHC.modInfoModBreaks =<< mi) + mi <- getModuleInfo m + return $ mkTickArray . assocs . modBreaks_locs <$> (modInfoModBreaks =<< mi) where mkTickArray :: [(BreakIndex, SrcSpan)] -> TickArray mkTickArray ticks = accumArray (flip (:)) [] (1, max_line) [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ] where - max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ] - srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ] + max_line = foldr max 0 [ srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ] + srcSpanLines pan = [ srcSpanStartLine pan .. srcSpanEndLine pan ] -- | Get the 'ModBreaks' of the given 'Module' when available -getModBreak :: GHC.GhcMonad m - => Module -> m (Maybe ModBreaks) +getModBreak :: GhcMonad m => Module -> m (Maybe ModBreaks) getModBreak m = do - mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m - pure $ GHC.modInfoModBreaks mod_info + mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m + pure $ modInfoModBreaks mod_info -------------------------------------------------------------------------------- -- Getting current breakpoint information -------------------------------------------------------------------------------- -getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan) +getCurrentBreakSpan :: GhcMonad m => m (Maybe SrcSpan) getCurrentBreakSpan = do - resumes <- GHC.getResumeContext + hug <- hsc_HUG <$> getSession + resumes <- getResumeContext case resumes of [] -> return Nothing (r:_) -> do - let ix = GHC.resumeHistoryIx r + let ix = resumeHistoryIx r if ix == 0 - then return (Just (GHC.resumeSpan r)) + then return (Just (resumeSpan r)) else do - let hist = GHC.resumeHistory r !! (ix-1) - pan <- GHC.getHistorySpan hist + let hist = resumeHistory r !! (ix-1) + pan <- liftIO $ getHistorySpan hug hist return (Just pan) -getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module) +getCurrentBreakModule :: GhcMonad m => m (Maybe Module) getCurrentBreakModule = do - resumes <- GHC.getResumeContext + resumes <- getResumeContext return $ case resumes of [] -> Nothing - (r:_) -> case GHC.resumeHistoryIx r of - 0 -> ibi_tick_mod <$> GHC.resumeBreakpointId r - ix -> Just $ GHC.getHistoryModule $ GHC.resumeHistory r !! (ix-1) + (r:_) -> case resumeHistoryIx r of + 0 -> ibi_tick_mod <$> resumeBreakpointId r + ix -> Just $ getHistoryModule $ resumeHistory r !! (ix-1) ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -144,25 +144,25 @@ import qualified GHC.Unit.Home.Graph as HUG getResumeContext :: GhcMonad m => m [Resume] getResumeContext = withSession (return . ic_resume . hsc_IC) -mkHistory :: HscEnv -> ForeignHValue -> InternalBreakpointId -> IO History -mkHistory hsc_env hval ibi = History hval ibi <$> findEnclosingDecls hsc_env ibi +mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History +mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi getHistoryModule :: History -> Module getHistoryModule = ibi_tick_mod . historyBreakpointId -getHistorySpan :: HscEnv -> History -> IO SrcSpan -getHistorySpan hsc_env hist = do +getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan +getHistorySpan hug hist = do let ibi = historyBreakpointId hist - brks <- readModBreaks hsc_env (ibi_tick_mod ibi) + brks <- readModBreaks hug (ibi_tick_mod ibi) return $ modBreaks_locs brks ! ibi_tick_index ibi {- | Finds the enclosing top level function name -} -- ToDo: a better way to do this would be to keep hold of the decl_path computed -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick. -findEnclosingDecls :: HscEnv -> InternalBreakpointId -> IO [String] -findEnclosingDecls hsc_env ibi = do - brks <- readModBreaks hsc_env (ibi_tick_mod ibi) +findEnclosingDecls :: HUG.HomeUnitGraph -> InternalBreakpointId -> IO [String] +findEnclosingDecls hug ibi = do + brks <- readModBreaks hug (ibi_tick_mod ibi) return $ modBreaks_decls brks ! ibi_tick_index ibi -- | Update fixity environment in the current interactive context. @@ -349,7 +349,8 @@ handleRunStatus step expr bindings final_ids status history0 = do -- - or one of the stepping options in @EvalOpts@ caused us to stop at one EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do let ibi = evalBreakpointToId eval_break - tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi) + let hug = hsc_HUG hsc_env + tick_brks <- liftIO $ readModBreaks hug (ibi_tick_mod ibi) let span = modBreaks_locs tick_brks ! ibi_tick_index ibi decl = intercalate "." $ modBreaks_decls tick_brks ! ibi_tick_index ibi @@ -390,7 +391,7 @@ handleRunStatus step expr bindings final_ids status history0 = do let eval_opts = initEvalOpts dflags (enableGhcStepMode step) status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv history <- if not tracing then pure history0 else do - history1 <- liftIO $ mkHistory hsc_env apStack_fhv ibi + history1 <- liftIO $ mkHistory hug apStack_fhv ibi let !history' = history1 `consBL` history0 -- history is strict, otherwise our BoundedList is pointless. return history' @@ -443,27 +444,27 @@ resumeExec step mbCnt -- When the user specified a break ignore count, set it -- in the interpreter case (mb_brkpt, mbCnt) of - (Just brkpt, Just cnt) -> setupBreakpoint hsc_env (toBreakpointId brkpt) cnt + (Just brkpt, Just cnt) -> setupBreakpoint interp (toBreakpointId brkpt) cnt _ -> return () let eval_opts = initEvalOpts dflags (enableGhcStepMode step) status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv let prevHistoryLst = fromListBL 50 hist + hug = hsc_HUG hsc_env hist' = case mb_brkpt of Nothing -> pure prevHistoryLst Just bi | breakHere False step span -> do - hist1 <- liftIO (mkHistory hsc_env apStack bi) + hist1 <- liftIO (mkHistory hug apStack bi) return $ hist1 `consBL` fromListBL 50 hist | otherwise -> pure prevHistoryLst handleRunStatus step expr bindings final_ids status =<< hist' -setupBreakpoint :: GhcMonad m => HscEnv -> BreakpointId -> Int -> m () -- #19157 -setupBreakpoint hsc_env bi cnt = do - let modl = bi_tick_mod bi - modBreaks <- liftIO $ readModBreaks hsc_env modl +setupBreakpoint :: GhcMonad m => Interp -> BreakpointId -> Int -> m () -- #19157 +setupBreakpoint interp bi cnt = do + hug <- hsc_HUG <$> getSession + modBreaks <- liftIO $ readModBreaks hug (bi_tick_mod bi) let breakarray = modBreaks_flags modBreaks - interp = hscInterp hsc_env _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt pure () @@ -494,7 +495,7 @@ moveHist fn = do span <- case mb_info of Nothing -> return $ mkGeneralSrcSpan (fsLit "<unknown>") Just ibi -> liftIO $ do - brks <- readModBreaks hsc_env (ibi_tick_mod ibi) + brks <- readModBreaks (hsc_HUG hsc_env) (ibi_tick_mod ibi) return $ modBreaks_locs brks ! ibi_tick_index ibi (hsc_env1, names) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info @@ -525,11 +526,6 @@ moveHist fn = do result_fs :: FastString result_fs = fsLit "_result" --- | Read the 'ModBreaks' of the given home 'Module' from the 'HomeUnitGraph'. -readModBreaks :: HscEnv -> Module -> IO ModBreaks -readModBreaks hsc_env mod = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule mod (hsc_HUG hsc_env) - - bindLocalsAtBreakpoint :: HscEnv -> ForeignHValue @@ -560,8 +556,9 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do - info_brks <- readModBreaks hsc_env (ibi_info_mod ibi) - tick_brks <- readModBreaks hsc_env (ibi_tick_mod ibi) + let hug = hsc_HUG hsc_env + info_brks <- readModBreaks hug (ibi_info_mod ibi) + tick_brks <- readModBreaks hug (ibi_tick_mod ibi) let info = expectJust $ IntMap.lookup (ibi_info_index ibi) (modBreaks_breakInfo info_brks) interp = hscInterp hsc_env occs = modBreaks_vars tick_brks ! ibi_tick_index ibi ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -27,10 +27,9 @@ module GHC.Runtime.Interpreter , getClosure , whereFrom , getModBreaks + , readModBreaks , seqHValue , evalBreakpointToId - , interpreterDynamic - , interpreterProfiled -- * The object-code linker , initObjLinker @@ -98,7 +97,6 @@ import GHC.Unit.Env #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run -import GHC.Platform.Ways #endif import Control.Concurrent @@ -117,6 +115,7 @@ import qualified GHC.InfoProv as InfoProv import GHC.Builtin.Names import GHC.Types.Name +import qualified GHC.Unit.Home.Graph as HUG -- Standard libraries import GHC.Exts @@ -732,13 +731,12 @@ wormholeRef interp _r = case interpInstance interp of ExternalInterp {} -> throwIO (InstallationError "this operation requires -fno-external-interpreter") --- ----------------------------------------------------------------------------- --- Misc utils - -fromEvalResult :: EvalResult a -> IO a -fromEvalResult (EvalException e) = throwIO (fromSerializableException e) -fromEvalResult (EvalSuccess a) = return a +-------------------------------------------------------------------------------- +-- * Finding breakpoint information +-------------------------------------------------------------------------------- +-- | Get the breakpoint information from the ByteCode object associated to this +-- 'HomeModInfo'. getModBreaks :: HomeModInfo -> Maybe ModBreaks getModBreaks hmi | Just linkable <- homeModInfoByteCode hmi, @@ -748,24 +746,15 @@ getModBreaks hmi | otherwise = Nothing -- probably object code --- | Interpreter uses Profiling way -interpreterProfiled :: Interp -> Bool -interpreterProfiled interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> hostIsProfiled -#endif - ExternalInterp ext -> case ext of - ExtIServ i -> iservConfProfiled (interpConfig i) - ExtJS {} -> False -- we don't support profiling yet in the JS backend - ExtWasm i -> wasmInterpProfiled $ interpConfig i - --- | Interpreter uses Dynamic way -interpreterDynamic :: Interp -> Bool -interpreterDynamic interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> hostIsDynamic -#endif - ExternalInterp ext -> case ext of - ExtIServ i -> iservConfDynamic (interpConfig i) - ExtJS {} -> False -- dynamic doesn't make sense for JS - ExtWasm {} -> True -- wasm dyld can only load dynamic code +-- | Read the 'InternalModBreaks' and 'ModBreaks' of the given home 'Module' +-- from the 'HomeUnitGraph'. +readModBreaks :: HomeUnitGraph -> Module -> IO ModBreaks +readModBreaks hug modl = expectJust . getModBreaks . expectJust <$> HUG.lookupHugByModule modl hug + +-- ----------------------------------------------------------------------------- +-- Misc utils + +fromEvalResult :: EvalResult a -> IO a +fromEvalResult (EvalException e) = throwIO (fromSerializableException e) +fromEvalResult (EvalSuccess a) = return a + ===================================== compiler/GHC/Runtime/Interpreter/Types.hs ===================================== @@ -24,7 +24,8 @@ module GHC.Runtime.Interpreter.Types , interpSymbolSuffix , eliminateInterpSymbol , interpretedInterpSymbol - + , interpreterProfiled + , interpreterDynamic -- * IServ , IServ @@ -48,6 +49,9 @@ import GHCi.RemoteTypes import GHCi.Message ( Pipe ) import GHC.Platform +#if defined(HAVE_INTERNAL_INTERPRETER) +import GHC.Platform.Ways +#endif import GHC.Utils.TmpFs import GHC.Utils.Logger import GHC.Unit.Env @@ -136,6 +140,28 @@ data ExtInterpInstance c = ExtInterpInstance -- ^ Instance specific extra fields } +-- | Interpreter uses Profiling way +interpreterProfiled :: Interp -> Bool +interpreterProfiled interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsProfiled +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfProfiled (interpConfig i) + ExtJS {} -> False -- we don't support profiling yet in the JS backend + ExtWasm i -> wasmInterpProfiled $ interpConfig i + +-- | Interpreter uses Dynamic way +interpreterDynamic :: Interp -> Bool +interpreterDynamic interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsDynamic +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfDynamic (interpConfig i) + ExtJS {} -> False -- dynamic doesn't make sense for JS + ExtWasm {} -> True -- wasm dyld can only load dynamic code + ------------------------ -- JS Stuff ------------------------ ===================================== compiler/GHC/Stg/BcPrep.hs ===================================== @@ -49,7 +49,7 @@ bcPrepRHS con@StgRhsCon{} = pure con bcPrepExpr :: StgExpr -> BcPrepM StgExpr -- explicitly match all constructors so we get a warning if we miss any -bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _ _) rhs) +bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs) | isLiftedTypeKind (typeKind tick_ty) = do id <- newId tick_ty rhs' <- bcPrepExpr rhs ===================================== compiler/GHC/Stg/FVs.hs ===================================== @@ -257,8 +257,8 @@ exprFVs env = go , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs = (StgTick tick e', imp_fvs, top_fvs, lcl_fvs') where - tickish (Breakpoint _ _ ids _) = mkDVarSet ids - tickish _ = emptyDVarSet + tickish (Breakpoint _ _ ids) = mkDVarSet ids + tickish _ = emptyDVarSet go_bind dc bind body = (dc bind' body', imp_fvs, top_fvs, lcl_fvs) where ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Platform.Profile import GHC.Runtime.Interpreter import GHCi.FFI import GHC.Types.Basic +import GHC.Types.Breakpoint import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Id @@ -388,7 +389,7 @@ schemeR_wrk fvs nm original_body (args, body) -- | Introduce break instructions for ticked expressions. -- If no breakpoint information is available, the instruction is omitted. schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList -schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do +schemeER_wrk d p (StgTick (Breakpoint tick_ty (BreakpointId tick_mod tick_no) fvs) rhs) = do code <- schemeE d 0 p rhs hsc_env <- getHscEnv current_mod <- getCurrentModule @@ -640,10 +641,9 @@ schemeE d s p (StgLet _ext binds body) = do thunk_codes <- sequence compile_binds return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) -schemeE _d _s _p (StgTick (Breakpoint _ bp_id _ _) _rhs) - = panic ("schemeE: Breakpoint without let binding: " ++ - show bp_id ++ - " forgot to run bcPrep?") +schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs) + = pprPanic "schemeE: Breakpoint without let binding: " $ + ppr bp_id <> text " forgot to run bcPrep?" -- ignore other kinds of tick schemeE d s p (StgTick _ rhs) = schemeE d s p rhs ===================================== compiler/GHC/Types/Breakpoint.hs ===================================== @@ -8,6 +8,9 @@ where import GHC.Prelude import GHC.Unit.Module +import GHC.Utils.Outputable +import Control.DeepSeq +import Data.Data (Data) -- | Breakpoint identifier. -- @@ -16,7 +19,7 @@ data BreakpointId = BreakpointId { bi_tick_mod :: !Module -- ^ Breakpoint tick module , bi_tick_index :: !Int -- ^ Breakpoint tick index } - deriving (Eq, Ord) + deriving (Eq, Ord, Data) -- | Internal breakpoint identifier -- @@ -53,3 +56,11 @@ toBreakpointId ibi = BreakpointId -- So every breakpoint occurrence gets assigned a module-unique *info index* and -- we store it alongside the occurrence module (*info module*) in the -- InternalBreakpointId datatype. + +instance Outputable BreakpointId where + ppr BreakpointId{bi_tick_mod, bi_tick_index} = + text "BreakpointId" <+> ppr bi_tick_mod <+> ppr bi_tick_index + +instance NFData BreakpointId where + rnf BreakpointId{bi_tick_mod, bi_tick_index} = + rnf bi_tick_mod `seq` rnf bi_tick_index ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Core.Type import GHC.Unit.Module +import GHC.Types.Breakpoint import GHC.Types.CostCentre import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) import GHC.Types.Var @@ -128,7 +129,7 @@ data GenTickish pass = -- and (b) substituting (don't substitute for them) | Breakpoint { breakpointExt :: XBreakpoint pass - , breakpointId :: !Int + , breakpointId :: !BreakpointId , breakpointFVs :: [XTickishId pass] -- ^ the order of this list is important: -- it matches the order of the lists in the @@ -136,7 +137,6 @@ data GenTickish pass = -- -- Careful about substitution! See -- Note [substTickish] in "GHC.Core.Subst". - , breakpointModule :: Module } -- | A source note. ===================================== compiler/ghc.cabal.in ===================================== @@ -548,6 +548,7 @@ Library GHC.Driver.Plugins.External GHC.Driver.Ppr GHC.Driver.Session + GHC.Driver.Session.Inspect GHC.Driver.Session.Units GHC.Hs GHC.Hs.Basic View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/674a1380fa8dcc4715be6a028880cb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/674a1380fa8dcc4715be6a028880cb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-8] 8 commits: compiler: make ModBreaks serializable
by Rodrigo Mesquita (＠alt-romes) 30 Jun '25

30 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-8 at Glasgow Haskell Compiler / GHC Commits: aa10928a by Cheng Shao at 2025-06-30T16:45:01+01:00 compiler: make ModBreaks serializable - - - - - 5989a722 by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 refactor: "Inspecting the session" moved from GHC Moved utilities for inspecting the session from the GHC module to GHC.Driver.Session.Inspect Purely a clean up - - - - - ff7d68ab by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Pass the HUG to readModBreaks, not HscEnv A minor cleanup. The associated history and setupBreakpoint functions are changed accordingly. - - - - - cc8a6cd8 by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Move readModBreaks to GHC.Runtime.Interpreter With some small docs changes - - - - - 56218cbf by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Move interpreterProfiled to Interp.Types Moves interpreterProfiled and interpreterDynamic to GHC.Runtime.Interpreter.Types from GHC.Runtime.Interpreter. - - - - - e60ece5d by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 cleanup: Don't import GHC in Debugger.Breakpoints Remove the top-level import GHC from GHC.Runtime.Debugger.Breakpoints This makes the module dependencies more granular and cleans up the qualified imports from the code. - - - - - de60ae45 by Rodrigo Mesquita at 2025-06-30T19:08:43+01:00 refactor: Use BreakpointId in Core and Ifaces - - - - - 6502cff1 by Rodrigo Mesquita at 2025-06-30T19:19:02+01:00 Big refactor of breakpoints internal representation Big better At this point we now have to go and re-work the BrkArrays to consider internal breakpoints (generated in StgGen) and multi-threading. tomorrow. Continue refactor Lots of progress littel better compiler: make ModBreaks serializable Mais... BRK_FUN in rts Fixes Tweaks Checkpoint but segfaults in GC Start part 4.... simpler allow allocating breakarrays outside of linking but in the linker env still disassemble tack todo The BreakArray construction at link time was originally done by Cheng. Co-authored-by: Cheng Shao <terrorjack(a)type.dance> - - - - - 48 changed files: - compiler/GHC.hs - compiler/GHC/ByteCode/Asm.hs - + compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Main.hs - + compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/FVs.hs - compiler/GHC/StgToByteCode.hs - − compiler/GHC/Types/Breakpoint.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - rts/Disassembler.c - rts/Exception.cmm - rts/Interpreter.c The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f9e01b4d5e8c3d5a838e87b54b3832… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f9e01b4d5e8c3d5a838e87b54b3832… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/step-out-9] refactor: Use BreakpointId in Core and Ifaces
by Rodrigo Mesquita (＠alt-romes) 30 Jun '25

30 Jun '25

Rodrigo Mesquita pushed to branch wip/romes/step-out-9 at Glasgow Haskell Compiler / GHC Commits: 674a1380 by Rodrigo Mesquita at 2025-06-30T18:13:57+01:00 refactor: Use BreakpointId in Core and Ifaces - - - - - 21 changed files: - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/FVs.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Types/Breakpoint.hs - compiler/GHC/Types/Tickish.hs Changes: ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -287,7 +287,7 @@ exprs_fvs :: [CoreExpr] -> FV exprs_fvs exprs = mapUnionFV expr_fvs exprs tickish_fvs :: CoreTickish -> FV -tickish_fvs (Breakpoint _ _ ids _) = FV.mkFVs ids +tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids tickish_fvs _ = emptyFV {- ********************************************************************** @@ -759,8 +759,8 @@ freeVars = go , AnnTick tickish expr2 ) where expr2 = go expr - tickishFVs (Breakpoint _ _ ids _) = mkDVarSet ids - tickishFVs _ = emptyDVarSet + tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids + tickishFVs _ = emptyDVarSet go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -897,8 +897,8 @@ lintCoreExpr (Cast expr co) lintCoreExpr (Tick tickish expr) = do { case tickish of - Breakpoint _ _ ids _ -> forM_ ids $ \id -> lintIdOcc id 0 - _ -> return () + Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0 + _ -> return () ; markAllJoinsBadIf block_joins $ lintCoreExpr expr } where block_joins = not (tickish `tickishScopesLike` SoftScope) ===================================== compiler/GHC/Core/Map/Expr.hs ===================================== @@ -198,11 +198,10 @@ eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where eqDeBruijnTickish :: DeBruijn CoreTickish -> DeBruijn CoreTickish -> Bool eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where - go (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod) + go (Breakpoint lext lid lids) (Breakpoint rext rid rids) = lid == rid && D env1 lids == D env2 rids && lext == rext - && lmod == rmod go l r = l == r -- Compares for equality, modulo alpha ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2501,7 +2501,7 @@ occAnal env (Tick tickish body) -- For a non-soft tick scope, we can inline lambdas only, so we -- abandon tail calls, and do markAllInsideLam too: usage_lam - | Breakpoint _ _ ids _ <- tickish + | Breakpoint _ _ ids <- tickish = -- Never substitute for any of the Ids in a Breakpoint addManyOccs usage_lam (mkVarSet ids) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1461,8 +1461,8 @@ simplTick env tickish expr cont simplTickish env tickish - | Breakpoint ext n ids modl <- tickish - = Breakpoint ext n (mapMaybe (getDoneId . substId env) ids) modl + | Breakpoint ext bid ids <- tickish + = Breakpoint ext bid (mapMaybe (getDoneId . substId env) ids) | otherwise = tickish -- Push type application and coercion inside a tick ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Prelude import GHC.Core import GHC.Core.Stats (exprStats) +import GHC.Types.Breakpoint import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Literal( pprLiteral ) import GHC.Types.Name( pprInfixName, pprPrefixName ) @@ -694,10 +695,10 @@ instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where ppr modl, comma, ppr ix, text ">"] - ppr (Breakpoint _ext ix vars modl) = + ppr (Breakpoint _ext bid vars) = hcat [text "break<", - ppr modl, comma, - ppr ix, + ppr (bi_tick_mod bid), comma, + ppr (bi_tick_index bid), text ">", parens (hcat (punctuate comma (map ppr vars)))] ppr (ProfNote { profNoteCC = cc, ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -602,8 +602,8 @@ substDVarSet subst@(Subst _ _ tv_env cv_env) fvs ------------------ -- | Drop free vars from the breakpoint if they have a non-variable substitution. substTickish :: Subst -> CoreTickish -> CoreTickish -substTickish subst (Breakpoint ext n ids modl) - = Breakpoint ext n (mapMaybe do_one ids) modl +substTickish subst (Breakpoint ext bid ids) + = Breakpoint ext bid (mapMaybe do_one ids) where do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst ===================================== compiler/GHC/Core/Tidy.hs ===================================== @@ -235,8 +235,8 @@ tidyAlt env (Alt con vs rhs) ------------ Tickish -------------- tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish -tidyTickish env (Breakpoint ext ix ids modl) - = Breakpoint ext ix (map (tidyVarOcc env) ids) modl +tidyTickish env (Breakpoint ext bid ids) + = Breakpoint ext bid (map (tidyVarOcc env) ids) tidyTickish _ other_tickish = other_tickish ------------ Rules -------------- ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -2492,11 +2492,10 @@ cheapEqExpr' ignoreTick e1 e2 -- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool -eqTickish env (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod) +eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids) = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids && - lext == rext && - lmod == rmod + lext == rext eqTickish _ l r = l == r -- | Finds differences between core bindings, see @diffExpr@. ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -586,8 +586,8 @@ toIfaceTickish (ProfNote cc tick push) = IfaceSCC cc tick push toIfaceTickish (HpcTick modl ix) = IfaceHpcTick modl ix toIfaceTickish (SourceNote src (LexicalFastString names)) = IfaceSource src names -toIfaceTickish (Breakpoint _ ix fv m) = - IfaceBreakpoint ix (toIfaceVar <$> fv) m +toIfaceTickish (Breakpoint _ ix fv) = + IfaceBreakpoint ix (toIfaceVar <$> fv) --------------------- toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -643,10 +643,10 @@ coreToStgArgs (arg : args) = do -- Non-type argument coreToStgTick :: Type -- type of the ticked expression -> CoreTickish -> StgTickish -coreToStgTick _ty (HpcTick m i) = HpcTick m i -coreToStgTick _ty (SourceNote span nm) = SourceNote span nm -coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope -coreToStgTick !ty (Breakpoint _ bid fvs modl) = Breakpoint ty bid fvs modl +coreToStgTick _ty (HpcTick m i) = HpcTick m i +coreToStgTick _ty (SourceNote span nm) = SourceNote span nm +coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope +coreToStgTick !ty (Breakpoint _ bid fvs) = Breakpoint ty bid fvs -- --------------------------------------------------------------------------- -- The magic for lets: ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -842,9 +842,9 @@ cpeRhsE env (Tick tickish expr) = do { body <- cpeBodyNF env expr ; return (emptyFloats, mkTick tickish' body) } where - tickish' | Breakpoint ext n fvs modl <- tickish + tickish' | Breakpoint ext bid fvs <- tickish -- See also 'substTickish' - = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) modl + = Breakpoint ext bid (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) | otherwise = tickish ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Driver.Flags (DumpFlag(..)) import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Logger +import GHC.Types.Breakpoint import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Id @@ -1235,7 +1236,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do Breakpoints -> do i <- addMixEntry me - pure (Breakpoint noExtField i ids (this_mod env)) + pure (Breakpoint noExtField (BreakpointId (this_mod env) i) ids) SourceNotes | RealSrcSpan pos' _ <- pos -> return $ SourceNote pos' $ LexicalFastString cc_name ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -56,6 +56,7 @@ import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue) import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey, constraintKindTyConKey ) +import GHC.Types.Breakpoint import GHC.Types.Unique ( hasKey ) import GHC.Iface.Type import GHC.Iface.Recomp.Binary @@ -699,7 +700,7 @@ data IfaceTickish = IfaceHpcTick Module Int -- from HpcTick x | IfaceSCC CostCentre Bool Bool -- from ProfNote | IfaceSource RealSrcSpan FastString -- from SourceNote - | IfaceBreakpoint Int [IfaceExpr] Module -- from Breakpoint + | IfaceBreakpoint BreakpointId [IfaceExpr] -- from Breakpoint data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr -- Note: IfLclName, not IfaceBndr (and same with the case binder) @@ -1848,7 +1849,7 @@ pprIfaceTickish (IfaceSCC cc tick scope) = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) pprIfaceTickish (IfaceSource src _names) = braces (pprUserRealSpan True src) -pprIfaceTickish (IfaceBreakpoint m ix fvs) +pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs) = braces (text "break" <+> ppr m <+> ppr ix <+> ppr fvs) ------------------ @@ -2198,7 +2199,7 @@ freeNamesIfaceTyConParent (IfDataInstance ax tc tys) = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys freeNamesIfTickish :: IfaceTickish -> NameSet -freeNamesIfTickish (IfaceBreakpoint _ fvs _) = +freeNamesIfTickish (IfaceBreakpoint _ fvs) = fnList freeNamesIfExpr fvs freeNamesIfTickish _ = emptyNameSet @@ -2919,7 +2920,7 @@ instance Binary IfaceTickish where put_ bh (srcSpanEndLine src) put_ bh (srcSpanEndCol src) put_ bh name - put_ bh (IfaceBreakpoint m ix fvs) = do + put_ bh (IfaceBreakpoint (BreakpointId m ix) fvs) = do putByte bh 3 put_ bh m put_ bh ix @@ -2947,7 +2948,7 @@ instance Binary IfaceTickish where 3 -> do m <- get bh ix <- get bh fvs <- get bh - return (IfaceBreakpoint m ix fvs) + return (IfaceBreakpoint (BreakpointId m ix) fvs) _ -> panic ("get IfaceTickish " ++ show h) instance Binary IfaceConAlt where @@ -3206,7 +3207,7 @@ instance NFData IfaceTickish where IfaceHpcTick m i -> rnf m `seq` rnf i IfaceSCC cc b1 b2 -> rnf cc `seq` rnf b1 `seq` rnf b2 IfaceSource src str -> rnf src `seq` rnf str - IfaceBreakpoint m i fvs -> rnf m `seq` rnf i `seq` rnf fvs + IfaceBreakpoint i fvs -> rnf i `seq` rnf fvs instance NFData IfaceConAlt where rnf = \case ===================================== compiler/GHC/Iface/Tidy.hs ===================================== @@ -955,7 +955,7 @@ dffvExpr :: CoreExpr -> DFFV () dffvExpr (Var v) = insert v dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 dffvExpr (Lam v e) = extendScope v (dffvExpr e) -dffvExpr (Tick (Breakpoint _ _ ids _) e) = mapM_ insert ids >> dffvExpr e +dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e dffvExpr (Tick _other e) = dffvExpr e dffvExpr (Cast e _) = dffvExpr e dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -1732,9 +1732,9 @@ tcIfaceTickish :: IfaceTickish -> IfL CoreTickish tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) tcIfaceTickish (IfaceSource src name) = return (SourceNote src (LexicalFastString name)) -tcIfaceTickish (IfaceBreakpoint ix fvs modl) = do +tcIfaceTickish (IfaceBreakpoint bid fvs) = do fvs' <- mapM tcIfaceExpr fvs - return (Breakpoint NoExtField ix [f | Var f <- fvs'] modl) + return (Breakpoint NoExtField bid [f | Var f <- fvs']) ------------------------- tcIfaceLit :: Literal -> IfL Literal ===================================== compiler/GHC/Stg/BcPrep.hs ===================================== @@ -49,7 +49,7 @@ bcPrepRHS con@StgRhsCon{} = pure con bcPrepExpr :: StgExpr -> BcPrepM StgExpr -- explicitly match all constructors so we get a warning if we miss any -bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _ _) rhs) +bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs) | isLiftedTypeKind (typeKind tick_ty) = do id <- newId tick_ty rhs' <- bcPrepExpr rhs ===================================== compiler/GHC/Stg/FVs.hs ===================================== @@ -257,8 +257,8 @@ exprFVs env = go , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs = (StgTick tick e', imp_fvs, top_fvs, lcl_fvs') where - tickish (Breakpoint _ _ ids _) = mkDVarSet ids - tickish _ = emptyDVarSet + tickish (Breakpoint _ _ ids) = mkDVarSet ids + tickish _ = emptyDVarSet go_bind dc bind body = (dc bind' body', imp_fvs, top_fvs, lcl_fvs) where ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Platform.Profile import GHC.Runtime.Interpreter import GHCi.FFI import GHC.Types.Basic +import GHC.Types.Breakpoint import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Id @@ -388,7 +389,7 @@ schemeR_wrk fvs nm original_body (args, body) -- | Introduce break instructions for ticked expressions. -- If no breakpoint information is available, the instruction is omitted. schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList -schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do +schemeER_wrk d p (StgTick (Breakpoint tick_ty (BreakpointId tick_mod tick_no) fvs) rhs) = do code <- schemeE d 0 p rhs hsc_env <- getHscEnv current_mod <- getCurrentModule @@ -640,10 +641,9 @@ schemeE d s p (StgLet _ext binds body) = do thunk_codes <- sequence compile_binds return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) -schemeE _d _s _p (StgTick (Breakpoint _ bp_id _ _) _rhs) - = panic ("schemeE: Breakpoint without let binding: " ++ - show bp_id ++ - " forgot to run bcPrep?") +schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs) + = pprPanic "schemeE: Breakpoint without let binding: " $ + ppr bp_id <> text " forgot to run bcPrep?" -- ignore other kinds of tick schemeE d s p (StgTick _ rhs) = schemeE d s p rhs ===================================== compiler/GHC/Types/Breakpoint.hs ===================================== @@ -8,6 +8,9 @@ where import GHC.Prelude import GHC.Unit.Module +import GHC.Utils.Outputable +import Control.DeepSeq +import Data.Data (Data) -- | Breakpoint identifier. -- @@ -16,7 +19,7 @@ data BreakpointId = BreakpointId { bi_tick_mod :: !Module -- ^ Breakpoint tick module , bi_tick_index :: !Int -- ^ Breakpoint tick index } - deriving (Eq, Ord) + deriving (Eq, Ord, Data) -- | Internal breakpoint identifier -- @@ -53,3 +56,11 @@ toBreakpointId ibi = BreakpointId -- So every breakpoint occurrence gets assigned a module-unique *info index* and -- we store it alongside the occurrence module (*info module*) in the -- InternalBreakpointId datatype. + +instance Outputable BreakpointId where + ppr BreakpointId{bi_tick_mod, bi_tick_index} = + text "BreakpointId" <+> ppr bi_tick_mod <+> ppr bi_tick_index + +instance NFData BreakpointId where + rnf BreakpointId{bi_tick_mod, bi_tick_index} = + rnf bi_tick_mod `seq` rnf bi_tick_index ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -31,6 +31,7 @@ import GHC.Core.Type import GHC.Unit.Module +import GHC.Types.Breakpoint import GHC.Types.CostCentre import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) import GHC.Types.Var @@ -128,7 +129,7 @@ data GenTickish pass = -- and (b) substituting (don't substitute for them) | Breakpoint { breakpointExt :: XBreakpoint pass - , breakpointId :: !Int + , breakpointId :: !BreakpointId , breakpointFVs :: [XTickishId pass] -- ^ the order of this list is important: -- it matches the order of the lists in the @@ -136,7 +137,6 @@ data GenTickish pass = -- -- Careful about substitution! See -- Note [substTickish] in "GHC.Core.Subst". - , breakpointModule :: Module } -- | A source note. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/674a1380fa8dcc4715be6a028880cbf… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/674a1380fa8dcc4715be6a028880cbf… You're receiving this email because of your account on gitlab.haskell.org.

1 0