[Git][ghc/ghc][wip/splice-imports-2025] 3 commits: More stage -> level
by Matthew Pickering (＠mpickering) 17 Apr '25
by Matthew Pickering (＠mpickering) 17 Apr '25
17 Apr '25
Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC
Commits:
5e145778 by Matthew Pickering at 2025-04-17T15:37:32+01:00
More stage -> level
- - - - -
be437442 by Matthew Pickering at 2025-04-17T15:42:05+01:00
Remove quoted name wrong stage error
- - - - -
88820305 by Matthew Pickering at 2025-04-17T15:44:55+01:00
fix note references
- - - - -
23 changed files:
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Types/TH.hs
- compiler/GHC/Tc/Utils/Concrete.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Types/Error/Codes.hs
Changes:
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -238,8 +238,8 @@ newTopSrcBinder (L loc rdr_name)
-- Binders should not be qualified; if they are, and with a different
-- module name, we get a confusing "M.T is not in scope" error later
- ; stage <- getStage
- ; if isBrackStage stage then
+ ; level <- getThLevel
+ ; if isBrackLevel level then
-- We are inside a TH bracket, so make an *Internal* name
-- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names
do { uniq <- newUnique
@@ -1015,7 +1015,7 @@ lookupLocalOccRn_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; return (lookupLocalRdrEnv local_env rdr_name) }
-lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))
+lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevelIndex))
-- Just look in the local environment
lookupLocalOccThLvl_maybe name
= do { lcl_env <- getLclEnv
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -33,7 +33,7 @@ import GHC.Prelude hiding (head, init, last, scanl, tail)
import GHC.Hs
import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Env ( isBrackStage )
+import GHC.Tc.Utils.Env ( isBrackLevel )
import GHC.Tc.Utils.Monad
import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS
@@ -656,8 +656,8 @@ rnExpr e@(HsStatic _ expr) = do
unlessXOptM LangExt.StaticPointers $
addErr $ TcRnIllegalStaticExpression e
(expr',fvExpr) <- rnLExpr expr
- stage <- getStage
- case stage of
+ level <- getThLevel
+ case level of
Splice _ _ -> addErr $ TcRnTHError $ IllegalStaticFormInSplice e
_ -> return ()
mod <- getModule
@@ -1152,7 +1152,7 @@ postProcessStmtsForApplicativeDo ctxt stmts
| otherwise = False
-- don't apply the transformation inside TH brackets, because
-- GHC.HsToCore.Quote does not handle ApplicativeDo.
- ; in_th_bracket <- isBrackStage <$> getStage
+ ; in_th_bracket <- isBrackLevel <$> getThLevel
; if ado_is_on && is_do_expr && not in_th_bracket
then do { traceRn "ppsfa" (ppr stmts)
; rearrangeForApplicativeDo ctxt stmts }
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -348,8 +348,8 @@ rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
rnAnnDecl ann@(HsAnnotation (_, s) provenance expr)
= addErrCtxt (AnnCtxt ann) $
do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
- ; cur_stage <- getStage
- ; (expr', expr_fvs) <- setStage (Splice Untyped cur_stage) $
+ ; cur_level <- getThLevel
+ ; (expr', expr_fvs) <- setThLevel (Splice Untyped cur_level) $
rnLExpr expr
; return (HsAnnotation (noAnn, s) provenance' expr',
provenance_fvs `plusFV` expr_fvs) }
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -635,7 +635,7 @@ top level binders specially in two ways
See Note [GlobalRdrEnv shadowing]
3. We find out whether we are inside a [d| ... |] by testing the TH
- stage. This is a slight hack, because the stage field was really
+ level. This is a slight hack, because the level field was really
meant for the type checker, and here we are not interested in the
fields of Brack, hence the error thunks in thRnBrack.
-}
@@ -651,18 +651,18 @@ extendGlobalRdrEnvRn :: [GlobalRdrElt]
extendGlobalRdrEnvRn new_gres new_fixities
= checkNoErrs $ -- See Note [Fail fast on duplicate definitions]
do { (gbl_env, lcl_env) <- getEnvs
- ; stage <- getStage
+ ; level <- getThLevel
; isGHCi <- getIsGHCi
; let rdr_env = tcg_rdr_env gbl_env
fix_env = tcg_fix_env gbl_env
th_bndrs = getLclEnvThBndrs lcl_env
- th_lvl = thLevel stage
+ th_lvl = thLevelIndex level
-- Delete new_occs from global and local envs
-- If we are in a TemplateHaskell decl bracket,
-- we are going to shadow them
-- See Note [GlobalRdrEnv shadowing]
- inBracket = isBrackStage stage
+ inBracket = isBrackLevel level
lcl_env_TH = modifyLclCtxt (\lcl_env -> lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_gres_env }) lcl_env
-- See Note [GlobalRdrEnv shadowing]
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -124,8 +124,8 @@ rnTypedBracket e br_body
do { checkForTemplateHaskellQuotes e
-- Check for nested brackets
- ; cur_stage <- getStage
- ; case cur_stage of
+ ; cur_level <- getThLevel
+ ; case cur_level of
{ Splice _ _ -> return ()
-- See Note [Untyped quotes in typed splices and vice versa]
; RunSplice _ ->
@@ -141,7 +141,7 @@ rnTypedBracket e br_body
; recordThUse
; traceRn "Renaming typed TH bracket" empty
- ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body
+ ; (body', fvs_e) <- setThLevel (Brack cur_level RnPendingTyped) $ rnLExpr br_body
; return (HsTypedBracket noExtField body', fvs_e)
@@ -153,8 +153,8 @@ rnUntypedBracket e br_body
do { checkForTemplateHaskellQuotes e
-- Check for nested brackets
- ; cur_stage <- getStage
- ; case cur_stage of
+ ; cur_level <- getThLevel
+ ; case cur_level of
{ Splice _ _ -> return ()
-- See Note [Untyped quotes in typed splices and vice versa]
; RunSplice _ ->
@@ -174,7 +174,7 @@ rnUntypedBracket e br_body
; (body', fvs_e) <-
-- See Note [Rebindable syntax and Template Haskell]
unsetXOptM LangExt.RebindableSyntax $
- setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
+ setThLevel (Brack cur_level (RnPendingUntyped ps_var)) $
rn_utbracket br_body
; pendings <- readMutVar ps_var
; return (HsUntypedBracket pendings body', fvs_e)
@@ -279,14 +279,14 @@ rnUntypedSpliceGen :: (HsUntypedSplice GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnUntypedSpliceGen run_splice pend_splice splice
= addErrCtxt (UntypedSpliceCtxt splice) $ do
- { stage <- getStage
- ; case stage of
+ { level <- getThLevel
+ ; case level of
Brack _ RnPendingTyped
-> failWithTc $ thSyntaxError
$ MismatchedSpliceType Untyped IsSplice
- Brack pop_stage (RnPendingUntyped ps_var)
- -> do { (splice', fvs) <- setStage pop_stage $
+ Brack pop_level (RnPendingUntyped ps_var)
+ -> do { (splice', fvs) <- setThLevel pop_level $
rnUntypedSplice splice
; loc <- getSrcSpanM
; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
@@ -296,9 +296,9 @@ rnUntypedSpliceGen run_splice pend_splice splice
; return (result, fvs) }
_ -> do { checkTopSpliceAllowed splice
- ; cur_stage <- getStage
+ ; cur_level <- getThLevel
; (splice', fvs1) <- checkNoErrs $
- setStage (Splice Untyped cur_stage) $
+ setThLevel (Splice Untyped cur_level) $
rnUntypedSplice splice
-- checkNoErrs: don't attempt to run the splice if
-- renaming it failed; otherwise we get a cascade of
@@ -350,7 +350,7 @@ runRnSplice flavour run_meta ppr_res splice
-- Run the expression
; mod_finalizers_ref <- newTcRef []
- ; result <- setStage (RunSplice mod_finalizers_ref) $
+ ; result <- setThLevel (RunSplice mod_finalizers_ref) $
run_meta zonked_q_expr
; mod_finalizers <- readTcRef mod_finalizers_ref
; traceSplice (SpliceInfo { spliceDescription = what
@@ -434,10 +434,10 @@ rnTypedSplice :: LHsExpr GhcPs -- Typed splice expression
-> RnM (HsExpr GhcRn, FreeVars)
rnTypedSplice expr
= addErrCtxt (TypedSpliceCtxt Nothing expr) $ do
- { stage <- getStage
- ; case stage of
- Brack pop_stage RnPendingTyped
- -> setStage pop_stage rn_splice
+ { level <- getThLevel
+ ; case level of
+ Brack pop_level RnPendingTyped
+ -> setThLevel pop_level rn_splice
Brack _ (RnPendingUntyped _)
-> failWithTc $ thSyntaxError $ MismatchedSpliceType Typed IsSplice
@@ -445,8 +445,8 @@ rnTypedSplice expr
_ -> do { unlessXOptM LangExt.TemplateHaskell
(failWith $ thSyntaxError IllegalTHSplice)
- ; cur_stage <- getStage
- ; (result, fvs1) <- checkNoErrs $ setStage (Splice Typed cur_stage) rn_splice
+ ; cur_level <- getThLevel
+ ; (result, fvs1) <- checkNoErrs $ setThLevel (Splice Typed cur_level) rn_splice
-- checkNoErrs: don't attempt to run the splice if
-- renaming it failed; otherwise we get a cascade of
-- errors from e.g. unbound variables
@@ -790,9 +790,9 @@ rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
-- Declaration splice at the very top level of the module
rnTopSpliceDecls splice
= do { checkTopSpliceAllowed splice
- ; cur_stage <- getStage
+ ; cur_level <- getThLevel
; (rn_splice, fvs) <- checkNoErrs $
- setStage (Splice Untyped cur_stage) $
+ setThLevel (Splice Untyped cur_level) $
rnUntypedSplice splice
-- As always, be sure to checkNoErrs above lest we end up with
-- holes making it to typechecking, hence #12584.
@@ -909,27 +909,25 @@ checkThLocalTyName name
| otherwise
= do { traceRn "checkThLocalTyName" (ppr name)
- ; mb_local_use <- getStageAndBindLevel name
+ ; mb_local_use <- getCurrentAndBindLevel name
; case mb_local_use of {
Nothing -> return () ; -- Not a locally-bound thing
- Just (top_lvl, bind_lvl, use_stage) ->
- do { let use_lvl = thLevel use_stage
- -- We don't check the well stageness of name here.
+ Just (top_lvl, bind_lvl, use_lvl) ->
+ do { let use_lvl_idx = thLevelIndex use_lvl
+ -- We don't check the well levelledness of name here.
-- this would break test for #20969
--
-- Consequently there is no check&restiction for top level splices.
-- But it's annoying anyway.
--
- -- Therefore checkCrossStageLiftingTy shouldn't assume anything
+ -- Therefore checkCrossLevelLiftingTy shouldn't assume anything
-- about bind_lvl and use_lvl relation.
--
- -- ; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl
-
; traceRn "checkThLocalTyName" (ppr name <+> ppr bind_lvl
- <+> ppr use_stage
+ <+> ppr use_lvl
<+> ppr use_lvl)
; dflags <- getDynFlags
- ; checkCrossStageLiftingTy dflags top_lvl bind_lvl use_stage use_lvl name } } }
+ ; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl use_lvl_idx name } } }
-- | Check whether we are allowed to use a Name in this context (for TH purposes)
-- In the case of a level incorrect program, attempt to fix it by using
@@ -953,34 +951,34 @@ checkThLocalName allow_lifting name
| otherwise
= do {
- mb_local_use <- getStageAndBindLevel name
+ mb_local_use <- getCurrentAndBindLevel name
; case mb_local_use of {
Nothing -> return () ; -- Not a locally-bound thing
- Just (top_lvl, bind_lvl, use_stage) ->
- do { let use_lvl = thLevel use_stage
+ Just (top_lvl, bind_lvl, use_lvl) ->
+ do { let use_lvl_idx = thLevelIndex use_lvl
; cur_mod <- extractModule <$> getGblEnv
; let is_local
| Just mod <- nameModule_maybe name = mod == cur_mod
| otherwise = True
- ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl <+> ppr use_stage)
+ ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl <+> ppr use_lvl)
; dflags <- getDynFlags
; env <- getGlobalRdrEnv
; let mgre = lookupGRE_Name env name
- ; checkCrossStageLifting dflags (StageCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_stage use_lvl name } } }
+ ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name } } }
--------------------------------------
-checkCrossStageLifting :: DynFlags
- -> StageCheckReason
+checkCrossLevelLifting :: DynFlags
+ -> LevelCheckReason
-> TopLevelFlag
-> Bool
-> Bool
- -> Set.Set ThLevel
- -> ThStage
+ -> Set.Set ThLevelIndex
-> ThLevel
+ -> ThLevelIndex
-> Name -> TcM ()
-checkCrossStageLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_stage use_lvl name
+checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name
-- 1. If name is in-scope, at the correct level.
- | use_lvl `Set.member` bind_lvl = return ()
+ | use_lvl_idx `Set.member` bind_lvl = return ()
-- 2. Name is imported with -XImplicitStagePersistence
| not is_local
, xopt LangExt.ImplicitStagePersistence dflags = return ()
@@ -988,23 +986,23 @@ checkCrossStageLifting dflags reason top_lvl is_local allow_lifting bind_lvl use
-- to be persisted into the future.
| isTopLevel top_lvl
, is_local
- , any (use_lvl >=) (Set.toList bind_lvl)
+ , any (use_lvl_idx >=) (Set.toList bind_lvl)
, xopt LangExt.ImplicitStagePersistence dflags = when (isExternalName name) (keepAlive name)
-- 4. Name is in an untyped bracket, and we are allowed to attempt to lift.
- | Brack _ (RnPendingUntyped ps_var) <- use_stage -- Only for untyped brackets
+ | Brack _ (RnPendingUntyped ps_var) <- use_lvl -- Only for untyped brackets
, allow_lifting
= do
dflags <- getDynFlags
- check_cross_stage_lifting dflags top_lvl name ps_var
+ check_cross_level_lifting dflags top_lvl name ps_var
-- 5. For an typed bracket, these checks happen again later on (checkThLocalId)
-- In the future we should do all the level checks here.
- | Brack _ RnPendingTyped <- use_stage -- Lift for typed brackets is inserted later.
+ | Brack _ RnPendingTyped <- use_lvl -- Lift for typed brackets is inserted later.
= return ()
-- Otherwise, we have a level error, report.
- | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl)
+ | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx)
-check_cross_stage_lifting :: DynFlags -> TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
-check_cross_stage_lifting dflags top_lvl name ps_var
+check_cross_level_lifting :: DynFlags -> TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
+check_cross_level_lifting dflags top_lvl name ps_var
| isTopLevel top_lvl
, xopt LangExt.ImplicitStagePersistence dflags
-- Top-level identifiers in this module,
@@ -1027,7 +1025,7 @@ check_cross_stage_lifting dflags top_lvl name ps_var
-- If 'x' occurs many times we may get many identical
-- bindings of the same SplicePointName, but that doesn't
-- matter, although it's a mite untidy.
- do { traceRn "checkCrossStageLifting" (ppr name)
+ do { traceRn "checkCrossLevelLifting" (ppr name)
-- Construct the (lift x) expression
; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name)
@@ -1040,8 +1038,8 @@ check_cross_stage_lifting dflags top_lvl name ps_var
; ps <- readMutVar ps_var
; writeMutVar ps_var (pend_splice : ps) }
-checkCrossStageLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevel -> ThStage -> ThLevel -> Name -> TcM ()
-checkCrossStageLiftingTy dflags top_lvl bind_lvl _use_stage use_lvl name
+checkCrossLevelLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex -> Name -> TcM ()
+checkCrossLevelLiftingTy dflags top_lvl bind_lvl _use_lvl use_lvl_idx name
| isTopLevel top_lvl
, xopt LangExt.ImplicitStagePersistence dflags
= return ()
@@ -1052,8 +1050,8 @@ checkCrossStageLiftingTy dflags top_lvl bind_lvl _use_stage use_lvl name
-- Can also happen for negative cases
-- See comment in checkThLocalTyName:
- | use_lvl `notElem` bind_lvl
- = addDiagnostic $ TcRnBadlyLevelledType name bind_lvl use_lvl
+ | use_lvl_idx `notElem` bind_lvl
+ = addDiagnostic $ TcRnBadlyLevelledType name bind_lvl use_lvl_idx
| otherwise
= return ()
@@ -1094,7 +1092,7 @@ them in the keep-alive set.
Note [Quoting names]
~~~~~~~~~~~~~~~~~~~~
A quoted name 'n is a bit like a quoted expression [| n |], except that we
-have no cross-stage lifting (c.f. GHC.Tc.Gen.Expr.thBrackId). So, after incrementing
+have no cross-level lifting (c.f. GHC.Tc.Gen.Expr.thBrackId). So, after incrementing
the use-level to account for the brackets, the cases are:
bind > use Error
@@ -1113,7 +1111,7 @@ Examples:
\x. f 'x -- Not ok (bind = 1, use = 1)
-- (whereas \x. f [| x |] might have been ok, by
- -- cross-stage lifting
+ -- cross-level lifting
\y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -106,7 +106,7 @@ newLocalBndrsRn = mapM newLocalBndrRn
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names
= updLclCtxt $ \ lcl_env ->
- let th_level = thLevel (tcl_th_ctxt lcl_env)
+ let th_level = thLevelIndex (tcl_th_ctxt lcl_env)
th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
[ (n, (NotTopLevel, th_level)) | n <- names ]
rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1510,17 +1510,17 @@ instance Diagnostic TcRnMessage where
TcRnBadlyLevelled reason bind_lvl use_lvl
-> mkSimpleDecorated $
vcat $
- [ text "Level error:" <+> pprStageCheckReason reason <+>
+ [ text "Level error:" <+> pprLevelCheckReason reason <+>
hsep [text "is bound at level" <+> ppr bind_lvl,
text "but used at level" <+> ppr use_lvl]
] ++
[ hsep [ text "Hint: quoting" <+> thBrackets (ppUnless (isValName n) "t") (ppr n)
, text "or an enclosing expression would allow the quotation to be used at an earlier level"
]
- | StageCheckSplice n _ <- [reason]
+ | LevelCheckSplice n _ <- [reason]
] ++
[ "From imports" <+> (ppr (gre_imp gre))
- | StageCheckSplice _ (Just gre) <- [reason]
+ | LevelCheckSplice _ (Just gre) <- [reason]
, not (isEmptyBag (gre_imp gre)) ]
TcRnBadlyLevelledType name bind_lvl use_lvl
-> mkSimpleDecorated $
@@ -5770,11 +5770,11 @@ pprWrongThingSort =
WrongThingTyCon -> "type constructor"
WrongThingAxiom -> "axiom"
-pprStageCheckReason :: StageCheckReason -> SDoc
-pprStageCheckReason = \case
- StageCheckInstance _ t ->
+pprLevelCheckReason :: LevelCheckReason -> SDoc
+pprLevelCheckReason = \case
+ LevelCheckInstance _ t ->
text "instance for" <+> quotes (ppr t)
- StageCheckSplice t _ ->
+ LevelCheckSplice t _ ->
quotes (ppr t)
pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc
@@ -6877,10 +6877,6 @@ pprTHNameError = \case
mkSimpleDecorated $
hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.")
2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
- QuotedNameWrongStage quote ->
- mkSimpleDecorated $
- sep [ text "Stage error: the non-top-level quoted name" <+> ppr quote
- , text "must be used at the same stage at which it is bound." ]
pprTHReifyError :: THReifyError -> DecoratedSDoc
pprTHReifyError = \case
@@ -7002,7 +6998,6 @@ thSyntaxErrorReason = \case
thNameErrorReason :: THNameError -> DiagnosticReason
thNameErrorReason = \case
NonExactName {} -> ErrorWithoutFlag
- QuotedNameWrongStage {} -> ErrorWithoutFlag
thReifyErrorReason :: THReifyError -> DiagnosticReason
thReifyErrorReason = \case
@@ -7063,7 +7058,6 @@ thSyntaxErrorHints = \case
thNameErrorHints :: THNameError -> [GhcHint]
thNameErrorHints = \case
NonExactName {} -> noHints
- QuotedNameWrongStage {} -> noHints
thReifyErrorHints :: THReifyError -> [GhcHint]
thReifyErrorHints = \case
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -99,7 +99,7 @@ module GHC.Tc.Errors.Types (
, RuleLhsErrReason(..)
, HsigShapeMismatchReason(..)
, WrongThingSort(..)
- , StageCheckReason(..)
+ , LevelCheckReason(..)
, UninferrableTyVarCtx(..)
, PatSynInvalidRhsReason(..)
, BadFieldAnnotationReason(..)
@@ -3487,19 +3487,19 @@ data TcRnMessage where
-> !LookupInstanceErrReason
-> TcRnMessage
- {-| TcRnBadlyStaged is an error that occurs when a TH binding is used at an
+ {-| TcRnBadlyLevelled is an error that occurs when a TH binding is used at an
invalid level.
Test cases:
T17820d, T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9}
-}
TcRnBadlyLevelled
- :: !StageCheckReason -- ^ The binding
- -> !(Set.Set Int) -- ^ The binding levels
- -> !Int -- ^ The level at which the binding is used.
+ :: !LevelCheckReason -- ^ The binding
+ -> !(Set.Set ThLevelIndex) -- ^ The binding levels
+ -> !ThLevelIndex -- ^ The level at which the binding is used.
-> TcRnMessage
- {-| TcRnBadlyStagedWarn is a warning that occurs when a TH type binding is
+ {-| TcRnBadlyLevelledWarn is a warning that occurs when a TH type binding is
used in an invalid stage.
Controlled by flags:
@@ -3510,8 +3510,8 @@ data TcRnMessage where
-}
TcRnBadlyLevelledType
:: !Name -- ^ The type binding being spliced.
- -> !(Set.Set Int) -- ^ The binding stage.
- -> !Int -- ^ The stage at which the binding is used.
+ -> !(Set.Set ThLevelIndex) -- ^ The binding stage.
+ -> !ThLevelIndex -- ^ The stage at which the binding is used.
-> TcRnMessage
{-| TcRnTyThingUsedWrong is an error that occurs when a thing is used where another
@@ -6245,9 +6245,9 @@ data WrongThingSort
| WrongThingTyCon
| WrongThingAxiom
-data StageCheckReason
- = StageCheckInstance !InstanceWhat !PredType
- | StageCheckSplice !Name !(Maybe GlobalRdrElt)
+data LevelCheckReason
+ = LevelCheckInstance !InstanceWhat !PredType
+ | LevelCheckSplice !Name !(Maybe GlobalRdrElt)
data UninferrableTyVarCtx
= UninfTyCtx_ClassContext [TcType]
@@ -6745,13 +6745,6 @@ data THNameError
-}
= NonExactName !RdrName
- {-| QuotedNameWrongStage is an error that can happen when a
- (non-top-level) Name is used at a different Template Haskell stage
- than the stage at which it is bound.
-
- Test cases: T16976z
- -}
- | QuotedNameWrongStage !(HsQuote GhcPs)
deriving Generic
data THReifyError
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -1217,13 +1217,13 @@ tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_ty
--
-- See [Wrinkle: VTA] in Note [Representation-polymorphism checking built-ins]
-- in GHC.Tc.Utils.Concrete.
- ; th_stage <- getStage
+ ; th_lvl <- getThLevel
; ty_arg <- case mb_conc of
Nothing -> return ty_arg0
Just conc
-- See [Wrinkle: Typed Template Haskell]
-- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | Brack _ (TcPending {}) <- th_stage
+ | Brack _ (TcPending {}) <- th_lvl
-> return ty_arg0
| otherwise
->
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -1075,28 +1075,28 @@ Wrinkles
-- checkThLocalName.
checkThLocalId :: Id -> TcM ()
checkThLocalId id
- = do { mb_local_use <- getStageAndBindLevel (idName id)
+ = do { mb_local_use <- getCurrentAndBindLevel (idName id)
; case mb_local_use of
- Just (top_lvl, bind_lvl, use_stage)
- | thLevel use_stage `Set.notMember` bind_lvl
+ Just (top_lvl, bind_lvl, use_lvl)
+ | thLevelIndex use_lvl `Set.notMember` bind_lvl
-> do
dflags <- getDynFlags
- checkCrossStageLifting dflags top_lvl id use_stage
+ checkCrossLevelLifting dflags top_lvl id use_lvl
_ -> return () -- Not a locally-bound thing, or
-- no cross-stage link
}
--------------------------------------
-checkCrossStageLifting :: DynFlags -> TopLevelFlag -> Id -> ThStage -> TcM ()
+checkCrossLevelLifting :: DynFlags -> TopLevelFlag -> Id -> ThLevel -> TcM ()
-- If we are inside typed brackets, and (use_lvl > bind_lvl)
-- we must check whether there's a cross-stage lift to do
-- Examples \x -> [|| x ||]
-- [|| map ||]
--
--- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but
+-- This is similar to checkCrossLevelLifting in GHC.Rename.Splice, but
-- this code is applied to *typed* brackets.
-checkCrossStageLifting dflags top_lvl id (Brack _ (TcPending ps_var lie_var q))
+checkCrossLevelLifting dflags top_lvl id (Brack _ (TcPending ps_var lie_var q))
| isTopLevel top_lvl
, xopt LangExt.ImplicitStagePersistence dflags
= when (isExternalName id_name) (keepAlive id_name)
@@ -1146,7 +1146,7 @@ checkCrossStageLifting dflags top_lvl id (Brack _ (TcPending ps_var lie_var q))
where
id_name = idName id
-checkCrossStageLifting _ _ _ _ = return ()
+checkCrossLevelLifting _ _ _ _ = return ()
{-
Note [Lifting strings]
@@ -1181,7 +1181,7 @@ them at level 2 or 0.
The level which a name is availble at is stored in the 'GRE', in the normal
GlobalRdrEnv. The function `greLevels` returns the levels which a specific GRE
is imported at. The level information for a 'Name' is computed by `getStageAndBindLevel`.
-The level validity is checked by `checkCrossStageLifting`.
+The level validity is checked by `checkCrossLevelLifting`.
Instances are checked by `checkWellStagedDFun`, which computes the level an
instance by calling `checkWellStagedInstanceWhat`, which sees what is available at by looking at the module graph.
@@ -1189,7 +1189,7 @@ instance by calling `checkWellStagedInstanceWhat`, which sees what is available
That's it for the main implementation of the feature, and the rest is modifications
to the driver parts of the code to use this information. For example, in downsweep,
we only enable code generation for modules needed at the runtime stage.
-See Note [ExplicitLevelImports and -fno-code].
+See Note [-fno-code mode].
-}
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -173,8 +173,8 @@ import GHC.Rename.Doc (rnHsDoc)
{-
Note [Template Haskell state diagram]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here are the ThStages, s, their corresponding level numbers
-(the result of (thLevel s)), and their state transitions.
+Here are the ThLevels, their corresponding level numbers
+(the result of (thLevelIndex s)), and their state transitions.
The top level of the program is stage Comp:
Start here
@@ -447,7 +447,7 @@ without having to walk over the untyped bracket code. Our example
RENAMER (rnUntypedBracket):
-* Set the ThStage to (Brack s (RnPendingUntyped ps_var))
+* Set the ThLevel to (Brack s (RnPendingUntyped ps_var))
* Rename the body
@@ -557,7 +557,7 @@ RENAMER (rnTypedSplice): the renamer adds a SplicePointName, spn:
TYPECHECKER (tcTypedBracket):
-* Set the ThStage to (Brack s (TcPending ps_var lie_var))
+* Set the ThLevel to (Brack s (TcPending ps_var lie_var))
* Typecheck the body, and keep the elaborated result (despite never using it!)
@@ -669,7 +669,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
-- See Note [How brackets and nested splices are handled]
tcTypedBracket rn_expr expr res_ty
= addErrCtxt (TypedTHBracketCtxt expr) $
- do { cur_stage <- getStage
+ do { cur_lvl <- getThLevel
; ps_ref <- newMutVar []
; lie_var <- getConstraintVar -- Any constraints arising from nested splices
-- should get thrown into the constraint set
@@ -686,7 +686,7 @@ tcTypedBracket rn_expr expr res_ty
-- The typechecked expression won't be used, so we just discard it
-- (See Note [The life cycle of a TH quotation] in GHC.Hs.Expr)
-- We'll typecheck it again when we splice it in somewhere
- ; (tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $
+ ; (tc_expr, expr_ty) <- setThLevel (Brack cur_lvl (TcPending ps_ref lie_var wrapper)) $
tcScalingUsage ManyTy $
-- Scale by Many, TH lifting is currently nonlinear (#18465)
tcInferRhoNC expr
@@ -835,8 +835,8 @@ getUntypedSpliceBody (HsUntypedSpliceNested {})
tcTypedSplice splice_name expr res_ty
= addErrCtxt (TypedSpliceCtxt (Just splice_name) expr) $
setSrcSpan (getLocA expr) $ do
- { stage <- getStage
- ; case stage of
+ { lvl <- getThLevel
+ ; case lvl of
Splice {} -> tcTopSplice expr res_ty
Brack pop_stage pend -> tcNestedSplice pop_stage pend splice_name expr res_ty
RunSplice _ ->
@@ -889,7 +889,7 @@ tcTopSpliceExpr isTypedSplice tc_action
= checkNoErrs $ -- checkNoErrs: must not try to run the thing
-- if the type checker fails!
- setStage (Splice isTypedSplice Comp) $
+ setThLevel (Splice isTypedSplice Comp) $
do { -- Typecheck the expression
(mb_expr', wanted) <- tryCaptureConstraints tc_action
-- If tc_action fails (perhaps because of insoluble constraints)
@@ -904,7 +904,7 @@ tcTopSpliceExpr isTypedSplice tc_action
Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' }
------------------
-tcNestedSplice :: ThStage -> PendingStuff -> Name
+tcNestedSplice :: ThLevel -> PendingStuff -> Name
-> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- See Note [How brackets and nested splices are handled]
-- A splice inside brackets
@@ -912,7 +912,7 @@ tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) spl
= do { res_ty <- expTypeToType res_ty
; let rep = getRuntimeRep res_ty
; meta_exp_ty <- tcTExpTy m_var res_ty
- ; expr' <- setStage pop_stage $
+ ; expr' <- setThLevel pop_stage $
setConstraintVar lie_var $
tcCheckMonoExpr expr meta_exp_ty
; untype_code <- tcLookupId unTypeCodeName
@@ -940,7 +940,7 @@ runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)
-- See Note [Collecting modFinalizers in typed splices].
; modfinalizers_ref <- newTcRef []
-- Run the expression
- ; expr2 <- setStage (RunSplice modfinalizers_ref) $
+ ; expr2 <- setThLevel (RunSplice modfinalizers_ref) $
runMetaE zonked_q_expr
; mod_finalizers <- readTcRef modfinalizers_ref
; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
@@ -1651,15 +1651,15 @@ lookupThInstName th_type = do
-- | Adds a mod finalizer reference to the local environment.
addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
addModFinalizerRef finRef = do
- th_stage <- getStage
- case th_stage of
+ th_lvl <- getThLevel
+ case th_lvl of
RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)
-- This case happens only if a splice is executed and the caller does
- -- not set the 'ThStage' to 'RunSplice' to collect finalizers.
+ -- not set the 'ThLevel' to 'RunSplice' to collect finalizers.
-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
_ ->
pprPanic "addModFinalizer was called when no finalizers were collected"
- (ppr th_stage)
+ (ppr th_lvl)
-- | Releases the external interpreter state.
finishTH :: TcM ()
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -904,7 +904,7 @@ checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
-- Returns the CtLoc to used for sub-goals
-- Probably also want to call checkReductionDepth
checkInstanceOK loc what pred
- = do { checkWellStagedDFun loc what pred
+ = do { checkWellLevelledDFun loc what pred
; return deeper_loc }
where
deeper_loc = zap_origin (bumpCtLocDepth loc)
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -125,7 +125,7 @@ module GHC.Tc.Solver.Monad (
-- Misc
getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
matchFam, matchFamTcM,
- checkWellStagedDFun,
+ checkWellLevelledDFun,
pprEq,
-- Enforcing invariants for type equalities
@@ -1598,48 +1598,46 @@ recordUsedGREs gres
-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()
+checkWellLevelledDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()
-- Check that we do not try to use an instance before it is available. E.g.
-- instance Eq T where ...
-- f x = $( ... (\(p::T) -> p == p)... )
-- Here we can't use the equality function from the instance in the splice
-checkWellStagedDFun loc what pred
+checkWellLevelledDFun loc what pred
= do
- mbind_lvl <- checkWellStagedInstanceWhat what
- --env <- getLclEnv
- --use_lvl <- thLevel <$> (wrapTcS $ TcM.getStage)
+ mbind_lvl <- checkWellLevelledInstanceWhat what
case mbind_lvl of
Just (bind_lvl, is_local) ->
wrapTcS $ TcM.setCtLocM loc $ do
- { use_stage <- TcM.getStage
+ { use_lvl <- thLevelIndex <$> TcM.getThLevel
; dflags <- getDynFlags
- ; checkCrossStageClass dflags (StageCheckInstance what pred) bind_lvl (thLevel use_stage) is_local }
+ ; checkCrossLevelClass dflags (LevelCheckInstance what pred) bind_lvl use_lvl is_local }
-- If no level information is returned for an InstanceWhat, then it's safe to use
-- at any level.
Nothing -> return ()
--- TODO: Unify this with checkCrossStageLifting function
-checkCrossStageClass :: DynFlags -> StageCheckReason -> Set.Set ThLevel -> ThLevel
+-- TODO: Unify this with checkCrossLevelLifting function
+checkCrossLevelClass :: DynFlags -> LevelCheckReason -> Set.Set ThLevelIndex -> ThLevelIndex
-> Bool -> TcM ()
-checkCrossStageClass dflags reason bind_lvl use_lvl is_local
- -- If the Id is imported, ie global, then allow with PathCrossStagedPersist
+checkCrossLevelClass dflags reason bind_lvl use_lvl_idx is_local
+ -- If the Id is imported, ie global, then allow with ImplicitStagePersistence
| not is_local
, xopt LangExt.ImplicitStagePersistence dflags
= return ()
- | use_lvl `Set.member` bind_lvl = return ()
+ | use_lvl_idx `Set.member` bind_lvl = return ()
-- With path CSP, using later than bound is fine
| xopt LangExt.ImplicitStagePersistence dflags
- , any (use_lvl >=) bind_lvl = return ()
- | otherwise = TcM.failWithTc (TcRnBadlyLevelled reason bind_lvl use_lvl)
+ , any (use_lvl_idx >=) bind_lvl = return ()
+ | otherwise = TcM.failWithTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx)
-- | Returns the ThLevel of evidence for the solved constraint (if it has evidence)
--- See Note [Well-staged instance evidence]
-checkWellStagedInstanceWhat :: InstanceWhat -> TcS (Maybe (Set.Set ThLevel, Bool))
-checkWellStagedInstanceWhat what
+-- See Note [Well-levelled instance evidence]
+checkWellLevelledInstanceWhat :: InstanceWhat -> TcS (Maybe (Set.Set ThLevelIndex, Bool))
+checkWellLevelledInstanceWhat what
| TopLevInstance { iw_dfun_id = dfun_id } <- what
= do
-- MP: I am not sure if we have to only do this check for orphan instances.
@@ -1658,25 +1656,25 @@ checkWellStagedInstanceWhat what
instance_key = if moduleUnitId name_module `Set.member` hsc_all_home_unit_ids hsc_env
then (mkKey NormalLevel name_module)
else Right (moduleUnitId name_module)
- let lvls = [ -1 | splice_lvl instance_key]
- ++ [ 0 | normal_lvl instance_key]
- ++ [ 1 | quote_lvl instance_key]
+ let lvls = [ spliceLevelIndex | splice_lvl instance_key]
+ ++ [ topLevelIndex | normal_lvl instance_key]
+ ++ [ quoteLevelIndex | quote_lvl instance_key]
if isLocalId dfun_id
- then return $ Just ( (Set.singleton topLevel, True) )
+ then return $ Just ( (Set.singleton topLevelIndex, True) )
else return $ Just ( Set.fromList lvls, False )
| BuiltinTypeableInstance tc <- what
= do
cur_mod <- extractModule <$> getGblEnv
return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc)
- then (Set.singleton topLevel, True)
+ then (Set.singleton topLevelIndex, True)
-- TODO, not correct, needs similar checks to normal instances
- else (Set.fromList [(-1), topLevel], False))
+ else (Set.fromList [spliceLevelIndex, topLevelIndex], False))
| otherwise = return Nothing
{-
-Note [Well-staged instance evidence]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Well-levelled instance evidence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Evidence for instances must obey the same level restrictions as normal bindings.
In particular, it is forbidden to use an instance in a top-level splice in the
@@ -1716,12 +1714,12 @@ Main.hs:12:14: error:
Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on
`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT`
-is well levelled. It's easy to know the stage of `$tcT`: for imported TyCons it
+is well levelled. It's easy to know the level of `$tcT`: for imported TyCons it
will be the level of the imported TyCon Name, and for local TyCons it will be `toplevel`.
Therefore the `InstanceWhat` type had to be extended with
a special case for `Typeable`, which recorded the TyCon the evidence was for and
-could them be used to check that we were not attempting to evidence in a stage incorrect
+could them be used to check that we were not attempting to evidence in a level incorrect
manner.
-}
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -418,8 +418,8 @@ tcInstDeclsDeriv
-> [LDerivDecl GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
tcInstDeclsDeriv deriv_infos derivds
- = do th_stage <- getStage -- See Note [Deriving inside TH brackets]
- if isBrackStage th_stage
+ = do th_lvl <- getThLevel -- See Note [Deriving inside TH brackets]
+ if isBrackLevel th_lvl
then do { gbl_env <- getGblEnv
; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }
else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -59,9 +59,15 @@ module GHC.Tc.Types(
CompleteMatch, CompleteMatches,
-- Template Haskell
- ThStage(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..),
- topStage, topAnnStage, topSpliceStage,
- ThLevel, topLevel,thLevel,
+ ThLevel(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..),
+ topLevel, topAnnLevel, topSpliceLevel,
+ ThLevelIndex,
+ topLevelIndex,
+ spliceLevelIndex,
+ quoteLevelIndex,
+
+ thLevelIndex,
+
ForeignSrcLang(..), THDocs, DocLoc(..),
ThBindEnv,
=====================================
compiler/GHC/Tc/Types/LclEnv.hs
=====================================
@@ -11,13 +11,13 @@ module GHC.Tc.Types.LclEnv (
, getLclEnvLoc
, getLclEnvRdrEnv
, getLclEnvTcLevel
- , getLclEnvThStage
+ , getLclEnvThLevel
, setLclEnvTcLevel
, setLclEnvLoc
, setLclEnvRdrEnv
, setLclEnvBinderStack
, setLclEnvErrCtxt
- , setLclEnvThStage
+ , setLclEnvThLevel
, setLclEnvTypeEnv
, modifyLclEnvTcLevel
@@ -108,7 +108,7 @@ data TcLclCtxt
-- we can look up record field names
- tcl_th_ctxt :: ThStage, -- Template Haskell context
+ tcl_th_ctxt :: ThLevel, -- Template Haskell context
tcl_th_bndrs :: ThBindEnv, -- and binder info
-- The ThBindEnv records the TH binding level of in-scope Names
-- defined in this module (not imported)
@@ -121,11 +121,11 @@ data TcLclCtxt
-- Ids and TyVars defined in this module
}
-getLclEnvThStage :: TcLclEnv -> ThStage
-getLclEnvThStage = tcl_th_ctxt . tcl_lcl_ctxt
+getLclEnvThLevel :: TcLclEnv -> ThLevel
+getLclEnvThLevel = tcl_th_ctxt . tcl_lcl_ctxt
-setLclEnvThStage :: ThStage -> TcLclEnv -> TcLclEnv
-setLclEnvThStage s = modifyLclCtxt (\env -> env { tcl_th_ctxt = s })
+setLclEnvThLevel :: ThLevel -> TcLclEnv -> TcLclEnv
+setLclEnvThLevel l = modifyLclCtxt (\env -> env { tcl_th_ctxt = l })
getLclEnvThBndrs :: TcLclEnv -> ThBindEnv
getLclEnvThBndrs = tcl_th_bndrs . tcl_lcl_ctxt
@@ -187,7 +187,7 @@ modifyLclCtxt upd env =
type TcTypeEnv = NameEnv TcTyThing
-type ThBindEnv = NameEnv (TopLevelFlag, ThLevel)
+type ThBindEnv = NameEnv (TopLevelFlag, ThLevelIndex)
-- Domain = all Ids bound in this module (ie not imported)
-- The TopLevelFlag tells if the binding is syntactically top level.
-- We need to know this, because the cross-stage persistence story allows
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -1533,7 +1533,7 @@ data InstanceWhat -- How did we solve this constraint?
-- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
| BuiltinTypeableInstance TyCon -- Built-in solver for Typeable (T t1 .. tn)
- -- See Note [Well-staged instance evidence]
+ -- See Note [Well-levelled instance evidence]
| BuiltinInstance -- Built-in solver for (C t1 .. tn) where C is
-- KnownNat, .. etc (classes with no top-level evidence)
=====================================
compiler/GHC/Tc/Types/TH.hs
=====================================
@@ -1,14 +1,16 @@
module GHC.Tc.Types.TH (
SpliceType(..)
, SpliceOrBracket(..)
- , ThStage(..)
+ , ThLevel(..)
, PendingStuff(..)
- , ThLevel
+ , ThLevelIndex
, topLevel
- , topStage
- , topAnnStage
- , topSpliceStage
- , thLevel
+ , topAnnLevel
+ , topSpliceLevel
+ , thLevelIndex
+ , topLevelIndex
+ , spliceLevelIndex
+ , quoteLevelIndex
) where
import GHCi.RemoteTypes
@@ -27,12 +29,12 @@ import GHC.Hs.Expr ( PendingTcSplice, PendingRnSplice )
data SpliceType = Typed | Untyped
data SpliceOrBracket = IsSplice | IsBracket
-data ThStage -- See Note [Template Haskell state diagram]
+data ThLevel -- See Note [Template Haskell state diagram]
-- and Note [Template Haskell levels] in GHC.Tc.Gen.Splice
-- Start at: Comp
-- At bracket: wrap current stage in Brack
-- At splice: wrap current stage in Splice
- = Splice SpliceType ThStage -- Inside a splice
+ = Splice SpliceType ThLevel -- Inside a splice
| RunSplice (TcRef [ForeignRef (TH.Q ())])
-- Set when running a splice, i.e. NOT when renaming or typechecking the
@@ -53,7 +55,7 @@ data ThStage -- See Note [Template Haskell state diagram]
-- Binding level = 0
| Brack -- Inside brackets
- ThStage -- Enclosing stage
+ ThLevel -- Enclosing level
PendingStuff
data PendingStuff
@@ -73,35 +75,51 @@ data PendingStuff
-- `lift`.
-topStage, topAnnStage, topSpliceStage :: ThStage
-topStage = Comp
-topAnnStage = Splice Untyped Comp
-topSpliceStage = Splice Untyped Comp
+topLevel, topAnnLevel, topSpliceLevel :: ThLevel
+topLevel = Comp
+topAnnLevel = Splice Untyped Comp
+topSpliceLevel = Splice Untyped Comp
-instance Outputable ThStage where
+instance Outputable ThLevel where
ppr (Splice _ s) = text "Splice" <> parens (ppr s)
ppr (RunSplice _) = text "RunSplice"
ppr Comp = text "Comp"
ppr (Brack s _) = text "Brack" <> parens (ppr s)
-type ThLevel = Int
+-- | The integer which represents the level
+newtype ThLevelIndex = ThLevelIndex Int deriving (Eq, Ord)
-- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice
-- Incremented when going inside a bracket,
-- decremented when going inside a splice
-topLevel :: ThLevel
-topLevel = thLevel Comp
+instance Outputable ThLevelIndex where
+ ppr (ThLevelIndex i) = int i
-thLevel :: ThStage -> ThLevel
-thLevel (Splice _ s) = thLevel s - 1
-thLevel Comp = 0
-thLevel (Brack s _) = thLevel s + 1
-thLevel (RunSplice _) = thLevel (Splice Untyped Comp) -- previously: panic "thLevel: called when running a splice"
+incThLevelIndex :: ThLevelIndex -> ThLevelIndex
+incThLevelIndex (ThLevelIndex i) = ThLevelIndex (i + 1)
+
+decThLevelIndex :: ThLevelIndex -> ThLevelIndex
+decThLevelIndex (ThLevelIndex i) = ThLevelIndex (i - 1)
+
+topLevelIndex :: ThLevelIndex
+topLevelIndex = thLevelIndex Comp
+
+spliceLevelIndex :: ThLevelIndex
+spliceLevelIndex = thLevelIndex (Splice Untyped Comp)
+
+quoteLevelIndex :: ThLevelIndex
+quoteLevelIndex = thLevelIndex (Brack Comp RnPendingTyped)
+
+thLevelIndex :: ThLevel -> ThLevelIndex
+thLevelIndex (Splice _ s) = decThLevelIndex (thLevelIndex s)
+thLevelIndex Comp = ThLevelIndex 0
+thLevelIndex (Brack s _) = incThLevelIndex (thLevelIndex s)
+thLevelIndex (RunSplice _) = thLevelIndex (Splice Untyped Comp) -- previously: panic "thLevel: called when running a splice"
-- See Note [RunSplice ThLevel].
{- Note [RunSplice ThLevel]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The 'RunSplice' stage is set when executing a splice, and only when running a
+The 'RunSplice' level is set when executing a splice, and only when running a
splice. In particular it is not set when the splice is renamed or typechecked.
However, this is not true. `reifyInstances` for example does rename the given type,
=====================================
compiler/GHC/Tc/Utils/Concrete.hs
=====================================
@@ -670,7 +670,7 @@ checkFRR_with :: HasDebugCallStack
-- ^ Returns @(co, frr_ty)@ with @co :: ty ~# frr_ty@
-- and @frr_@ty has a fixed 'RuntimeRep'.
checkFRR_with check_kind frr_ctxt ty
- = do { th_stage <- getStage
+ = do { th_lvl <- getThLevel
; if
-- Shortcut: check for 'Type' and 'UnliftedType' type synonyms.
| TyConApp tc [] <- ki
@@ -678,7 +678,7 @@ checkFRR_with check_kind frr_ctxt ty
-> return refl
-- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep].
- | Brack _ (TcPending {}) <- th_stage
+ | Brack _ (TcPending {}) <- th_lvl
-> return refl
-- Otherwise: ensure that the kind 'ki' of 'ty' is concrete.
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -60,9 +60,9 @@ module GHC.Tc.Utils.Env(
tcGetDefaultTys,
-- Template Haskell stuff
- StageCheckReason(..),
- tcMetaTy, thLevel,
- isBrackStage,
+ LevelCheckReason(..),
+ tcMetaTy, thLevelIndex,
+ isBrackLevel,
-- New Ids
newDFunName,
@@ -521,9 +521,8 @@ tcExtendTyConEnv tycons thing_inside
-- See GHC ticket #17820 .
tcTyThBinders :: [TyThing] -> TcM ThBindEnv
tcTyThBinders implicit_things = do
- stage <- getStage
- let th_lvl = thLevel stage
- th_bndrs = mkNameEnv
+ th_lvl <- thLevelIndex <$> getThLevel
+ let th_bndrs = mkNameEnv
[ ( n , (TopLevel, th_lvl) ) | n <- names ]
return th_bndrs
where
@@ -759,7 +758,7 @@ tc_extend_local_env top_lvl extra_env thing_inside
= do { traceTc "tc_extend_local_env" (ppr extra_env)
; updLclCtxt upd_lcl_env thing_inside }
where
- upd_lcl_env env0@(TcLclCtxt { tcl_th_ctxt = stage
+ upd_lcl_env env0@(TcLclCtxt { tcl_th_ctxt = th_lvl
, tcl_rdr = rdr_env
, tcl_th_bndrs = th_bndrs
, tcl_env = lcl_type_env })
@@ -776,7 +775,7 @@ tc_extend_local_env top_lvl extra_env thing_inside
-- Template Haskell staging env simultaneously. Reason for extending
-- LocalRdrEnv: after running a TH splice we need to do renaming.
where
- thlvl = (top_lvl, thLevel stage)
+ thlvl = (top_lvl, thLevelIndex th_lvl)
tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcLclCtxt -> TcLclCtxt
@@ -931,9 +930,9 @@ tcMetaTy tc_name = do
t <- tcLookupTyCon tc_name
return (mkTyConTy t)
-isBrackStage :: ThStage -> Bool
-isBrackStage (Brack {}) = True
-isBrackStage _other = False
+isBrackLevel :: ThLevel -> Bool
+isBrackLevel (Brack {}) = True
+isBrackLevel _other = False
{-
************************************************************************
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -117,7 +117,7 @@ module GHC.Tc.Utils.Monad(
-- * Template Haskell context
recordThUse, recordThNeededRuntimeDeps,
- keepAlive, getStage, getStageAndBindLevel, setStage,
+ keepAlive, getThLevel, getCurrentAndBindLevel, setThLevel,
addModFinalizersWithLclEnv,
-- * Safe Haskell context
@@ -399,7 +399,7 @@ initTcWithGbl hsc_env gbl_env loc do_this
tcl_in_gen_code = False,
tcl_ctxt = [],
tcl_rdr = emptyLocalRdrEnv,
- tcl_th_ctxt = topStage,
+ tcl_th_ctxt = topLevel,
tcl_th_bndrs = emptyNameEnv,
tcl_arrow_ctxt = NoArrowCtxt,
tcl_env = emptyNameEnv,
@@ -2110,11 +2110,11 @@ keepAlive name
; traceRn "keep alive" (ppr name)
; updTcRef (tcg_keep env) (`extendNameSet` name) }
-getStage :: TcM ThStage
-getStage = do { env <- getLclEnv; return (getLclEnvThStage env) }
+getThLevel :: TcM ThLevel
+getThLevel = do { env <- getLclEnv; return (getLclEnvThLevel env) }
-getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevel, ThStage))
-getStageAndBindLevel name
+getCurrentAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel))
+getCurrentAndBindLevel name
= do { env <- getLclEnv;
; case lookupNameEnv (getLclEnvThBndrs env) name of
Nothing -> do
@@ -2128,10 +2128,10 @@ getStageAndBindLevel name
--env <- getGlobalRdrEnv
--pprTrace "NO_LVLS" (ppr name) (return Nothing)
return Nothing
- else return (Just (TopLevel, lvls, getLclEnvThStage env))
- Just (top_lvl, bind_lvl) -> return (Just (top_lvl, Set.singleton bind_lvl, getLclEnvThStage env)) }
+ else return (Just (TopLevel, lvls, getLclEnvThLevel env))
+ Just (top_lvl, bind_lvl) -> return (Just (top_lvl, Set.singleton bind_lvl, getLclEnvThLevel env)) }
-getExternalBindLvl :: Name -> TcRn (Set.Set ThLevel)
+getExternalBindLvl :: Name -> TcRn (Set.Set ThLevelIndex)
getExternalBindLvl name = do
env <- getGlobalRdrEnv
mod <- getModule
@@ -2139,16 +2139,16 @@ getExternalBindLvl name = do
Just gre -> return $ (Set.map convert_lvl (greLevels gre))
Nothing ->
if nameIsLocalOrFrom mod name
- then return $ Set.singleton topLevel
+ then return $ Set.singleton topLevelIndex
-- else pprTrace "NO LVLS" (ppr name) (return Set.empty) -- pprPanic "getExternalBindLvl" (ppr env $$ ppr name $$ ppr (nameSrcSpan name))
else return Set.empty
where
- convert_lvl NormalLevel = thLevel topStage
- convert_lvl SpliceLevel = thLevel topSpliceStage
- convert_lvl QuoteLevel = thLevel (Brack topStage undefined)
+ convert_lvl NormalLevel = topLevelIndex
+ convert_lvl SpliceLevel = spliceLevelIndex
+ convert_lvl QuoteLevel = quoteLevelIndex
-setStage :: ThStage -> TcM a -> TcRn a
-setStage s = updLclEnv (setLclEnvThStage s)
+setThLevel :: ThLevel -> TcM a -> TcRn a
+setThLevel l = updLclEnv (setLclEnvThLevel l)
-- | Adds the given modFinalizers to the global environment and set them to use
-- the current local environment.
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -458,11 +458,11 @@ newInferExpType = new_inferExpType Nothing
newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR
newInferExpTypeFRR frr_orig
- = do { th_stage <- getStage
+ = do { th_lvl <- getThLevel
; if
-- See [Wrinkle: Typed Template Haskell]
-- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | Brack _ (TcPending {}) <- th_stage
+ | Brack _ (TcPending {}) <- th_lvl
-> new_inferExpType Nothing
| otherwise
@@ -800,11 +800,11 @@ newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin
-> FastString -> TcKind -> TcM TcTyVar
newConcreteTyVar reason fs kind
= assertPpr (isConcreteType kind) assert_msg $
- do { th_stage <- getStage
+ do { th_lvl <- getThLevel
; if
-- See [Wrinkle: Typed Template Haskell]
-- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | Brack _ (TcPending {}) <- th_stage
+ | Brack _ (TcPending {}) <- th_lvl
-> newNamedAnonMetaTyVar fs TauTv kind
| otherwise
@@ -986,8 +986,8 @@ newOpenFlexiTyVar
-- in GHC.Tc.Utils.Concrete.
newOpenFlexiFRRTyVar :: FixedRuntimeRepContext -> TcM TcTyVar
newOpenFlexiFRRTyVar frr_ctxt
- = do { th_stage <- getStage
- ; case th_stage of
+ = do { th_lvl <- getThLevel
+ ; case th_lvl of
{ Brack _ (TcPending {}) -- See [Wrinkle: Typed Template Haskell]
-> newOpenFlexiTyVar -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
; _ ->
@@ -1040,11 +1040,11 @@ newMetaTyVarX = new_meta_tv_x TauTv
-- | Like 'newMetaTyVarX', but for concrete type variables.
newConcreteTyVarX :: ConcreteTvOrigin -> Subst -> TyVar -> TcM (Subst, TcTyVar)
newConcreteTyVarX conc subst tv
- = do { th_stage <- getStage
+ = do { th_lvl <- getThLevel
; if
-- See [Wrinkle: Typed Template Haskell]
-- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.
- | Brack _ (TcPending {}) <- th_stage
+ | Brack _ (TcPending {}) <- th_lvl
-> new_meta_tv_x TauTv subst tv
| otherwise
-> new_meta_tv_x (ConcreteTv conc) subst tv }
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -967,7 +967,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "NestedTHBrackets" = 59185
GhcDiagnosticCode "AddTopDeclsUnexpectedDeclarationSplice" = 17599
GhcDiagnosticCode "BadImplicitSplice" = 25277
- GhcDiagnosticCode "QuotedNameWrongStage" = 57695
+ GhcDiagnosticCode "QuotedNameWrongStage" = Outdated 57695
GhcDiagnosticCode "IllegalStaticFormInSplice" = 12219
-- Zonker messages
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/49dd72380ae886224fb16671699a58…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/49dd72380ae886224fb16671699a58…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/splice-imports-2025] 5 commits: Documentation
by Matthew Pickering (＠mpickering) 17 Apr '25
by Matthew Pickering (＠mpickering) 17 Apr '25
17 Apr '25
Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC
Commits:
9c357ba0 by Matthew Pickering at 2025-04-17T11:14:14+01:00
Documentation
- - - - -
ddbba2de by Matthew Pickering at 2025-04-17T11:55:35+01:00
wip, fix level numbers
- - - - -
cf9d37cd by Matthew Pickering at 2025-04-17T14:01:44+01:00
fixes
- - - - -
680d0f57 by Matthew Pickering at 2025-04-17T14:36:39+01:00
Levels rather than stages
- - - - -
49dd7238 by Matthew Pickering at 2025-04-17T14:42:24+01:00
Delete dead code (I tested the tests worked)
- - - - -
81 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/TH.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- − compiler/Language/Haskell/Syntax/ImpExp/ImportLevel.hs
- compiler/ghc.cabal.in
- docs/users_guide/exts/template_haskell.rst
- docs/users_guide/phases.rst
- docs/users_guide/using-warnings.rst
- testsuite/tests/annotations/should_fail/annfail03.stderr
- testsuite/tests/annotations/should_fail/annfail04.stderr
- testsuite/tests/annotations/should_fail/annfail06.stderr
- testsuite/tests/annotations/should_fail/annfail09.stderr
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/module/mod185.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/quasiquotation/qq001/qq001.stderr
- testsuite/tests/quasiquotation/qq002/qq002.stderr
- testsuite/tests/quasiquotation/qq003/qq003.stderr
- testsuite/tests/quasiquotation/qq004/qq004.stderr
- testsuite/tests/quotes/T5721.stderr
- testsuite/tests/splice-imports/SI03.stderr
- testsuite/tests/splice-imports/SI05.stderr
- testsuite/tests/splice-imports/SI08.stderr
- testsuite/tests/splice-imports/SI08_oneshot.stderr
- testsuite/tests/splice-imports/SI14.stderr
- testsuite/tests/splice-imports/SI15.stderr
- testsuite/tests/splice-imports/SI16.stderr
- testsuite/tests/splice-imports/SI18.stderr
- testsuite/tests/splice-imports/SI20.stderr
- + testsuite/tests/splice-imports/SI25.hs
- + testsuite/tests/splice-imports/SI25.stderr
- + testsuite/tests/splice-imports/SI25Helper.hs
- + testsuite/tests/splice-imports/SI26.hs
- + testsuite/tests/splice-imports/SI27.hs
- + testsuite/tests/splice-imports/SI27.stderr
- testsuite/tests/splice-imports/all.T
- testsuite/tests/th/T16976z.stderr
- testsuite/tests/th/T17820a.stderr
- testsuite/tests/th/T17820b.stderr
- testsuite/tests/th/T17820c.stderr
- testsuite/tests/th/T17820d.stderr
- testsuite/tests/th/T17820e.stderr
- testsuite/tests/th/T21547.stderr
- testsuite/tests/th/T23829_hasty.stderr
- testsuite/tests/th/T23829_hasty_b.stderr
- testsuite/tests/th/T23829_tardy.ghc.stderr
- testsuite/tests/th/T5795.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e1422c8a8e163070028b4b064544e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e1422c8a8e163070028b4b064544e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-debugger-unitid] Add `UnitId` to `EvalBreakpoint`
by Hannes Siebenhandl (＠fendor) 17 Apr '25
by Hannes Siebenhandl (＠fendor) 17 Apr '25
17 Apr '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-debugger-unitid at Glasgow Haskell Compiler / GHC
Commits:
91cb9703 by fendor at 2025-04-17T14:38:42+02:00
Add `UnitId` to `EvalBreakpoint`
The `EvalBreakpoint` is used to communicate that a breakpoint was
encountered during code evaluation.
This `EvalBreakpoint` needs to be converted to an `InternalBreakpointId`
which stores a `Module` to uniquely find the correct `Module` in the
Home Package Table.
The `EvalBreakpoint` used to store only a `ModuleName` which is then
converted to a `Module` based on the currently active home unit.
This is incorrect in the face of multiple home units, the break point
could be in an entirely other home unit!
To fix this, we additionally store the `UnitId` of the `Module` in
`EvalBreakpoint` to later reconstruct the correct `Module`
All of the changes are the consequence of extending `EvalBreakpoint`
with the additional `UnitId`.
- - - - -
11 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Exception.cmm
- rts/Interpreter.c
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -732,13 +732,16 @@ assembleI platform i = case i of
CCALL off m_addr i -> do np <- addr m_addr
emit_ bci_CCALL [wOp off, Op np, SmallOp i]
PRIMCALL -> emit_ bci_PRIMCALL []
- BRK_FUN arr tick_mod tickx info_mod infox cc ->
+ BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc ->
do p1 <- ptr (BCOPtrBreakArray arr)
tick_addr <- addr tick_mod
+ tick_unitid_addr <- addr tick_mod_id
info_addr <- addr info_mod
+ info_unitid_addr <- addr info_mod_id
np <- addr cc
emit_ bci_BRK_FUN [ Op p1
, Op tick_addr, Op info_addr
+ , Op tick_unitid_addr, Op info_unitid_addr
, SmallOp tickx, SmallOp infox
, Op np
]
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Stg.Syntax
import GHCi.BreakArray (BreakArray)
import Language.Haskell.Syntax.Module.Name (ModuleName)
import GHC.Types.Unique
+import GHC.Unit.Types (UnitId)
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -233,8 +234,10 @@ data BCInstr
-- Breakpoints
| BRK_FUN (ForeignRef BreakArray)
(RemotePtr ModuleName) -- breakpoint tick module
+ (RemotePtr UnitId) -- breakpoint tick module unit id
!Word16 -- breakpoint tick index
(RemotePtr ModuleName) -- breakpoint info module
+ (RemotePtr UnitId) -- breakpoint info module unit id
!Word16 -- breakpoint info index
(RemotePtr CostCentre)
@@ -403,10 +406,10 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk
ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
- ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)
+ ppr (BRK_FUN _ _tick_mod _tick_mod_id tickx _info_mod _info_mod_id infox _)
= text "BRK_FUN" <+> text "<breakarray>"
- <+> text "<tick_module>" <+> ppr tickx
- <+> text "<info_module>" <+> ppr infox
+ <+> text "<tick_module>" <+> text "<tick_module_unitid>" <+> ppr tickx
+ <+> text "<info_module>" <+> text "<info_module_unitid>" <+> ppr infox
<+> text "<cc>"
#if MIN_VERSION_rts(1,0,3)
ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm)
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -50,6 +50,7 @@ import GHC.Stack.CCS
import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
import GHC.Iface.Syntax
import Language.Haskell.Syntax.Module.Name (ModuleName)
+import GHC.Unit.Types (UnitId)
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -263,6 +264,9 @@ data ModBreaks
, modBreaks_breakInfo :: IntMap CgBreakInfo
-- ^ info about each breakpoint from the bytecode generator
, modBreaks_module :: RemotePtr ModuleName
+ -- ^ info about the module in which we are setting the breakpoint
+ , modBreaks_module_unitid :: RemotePtr UnitId
+ -- ^ The 'UnitId' of the 'ModuleName'
}
seqModBreaks :: ModBreaks -> ()
@@ -273,7 +277,8 @@ seqModBreaks ModBreaks{..} =
rnf modBreaks_decls `seq`
rnf modBreaks_ccs `seq`
rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq`
- rnf modBreaks_module
+ rnf modBreaks_module `seq`
+ rnf modBreaks_module_unitid
-- | Construct an empty ModBreaks
emptyModBreaks :: ModBreaks
@@ -286,6 +291,7 @@ emptyModBreaks = ModBreaks
, modBreaks_ccs = array (0,-1) []
, modBreaks_breakInfo = IntMap.empty
, modBreaks_module = toRemotePtr nullPtr
+ , modBreaks_module_unitid = toRemotePtr nullPtr
}
{-
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -34,7 +34,7 @@ mkModBreaks interp mod extendedMixEntries
breakArray <- GHCi.newBreakArray interp count
ccs <- mkCCSArray interp mod count entries
- mod_ptr <- GHCi.newModuleName interp (moduleName mod)
+ (mod_ptr, mod_id_ptr) <- GHCi.newModule interp mod
let
locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
@@ -46,6 +46,7 @@ mkModBreaks interp mod extendedMixEntries
, modBreaks_decls = declsTicks
, modBreaks_ccs = ccs
, modBreaks_module = mod_ptr
+ , modBreaks_module_unitid = mod_id_ptr
}
mkCCSArray
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -345,7 +345,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
-- Just case: we stopped at a breakpoint
EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
- ibi <- liftIO $ evalBreakpointToId (hsc_HPT hsc_env) eval_break
+ let ibi = evalBreakpointToId eval_break
tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi)
let
span = modBreaks_locs tick_brks ! ibi_tick_index ibi
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Runtime.Interpreter
, mkCostCentres
, costCentreStackInfo
, newBreakArray
- , newModuleName
+ , newModule
, storeBreakpoint
, breakpointStatus
, getBreakpointVar
@@ -93,9 +93,7 @@ import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe)
import GHC.Utils.Fingerprint
import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
import GHC.Unit.Home.ModInfo
-import GHC.Unit.Home.PackageTable
import GHC.Unit.Env
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -119,6 +117,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
@@ -377,9 +376,13 @@ newBreakArray interp size = do
breakArray <- interpCmd interp (NewBreakArray size)
mkFinalizedHValue interp breakArray
-newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)
-newModuleName interp mod_name =
- castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name))
+newModule :: Interp -> Module -> IO (RemotePtr ModuleName, RemotePtr UnitId)
+newModule interp mod = do
+ let
+ mod_name = moduleNameString $ moduleName mod
+ mod_id = unitIdString $ toUnitId $ moduleUnit mod
+ (mod_ptr, mod_id_ptr) <- interpCmd interp (NewBreakModule mod_name mod_id)
+ pure (castRemotePtr mod_ptr, castRemotePtr mod_id_ptr)
storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()
storeBreakpoint interp ref ix cnt = do -- #19157
@@ -415,19 +418,21 @@ seqHValue interp unit_env ref =
status <- interpCmd interp (Seq hval)
handleSeqHValueStatus interp unit_env status
-evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> IO InternalBreakpointId
-evalBreakpointToId hpt eval_break =
- let load_mod x = mi_module . hm_iface . expectJust <$> lookupHpt hpt (mkModuleName x)
- in do
- tickl <- load_mod (eb_tick_mod eval_break)
- infol <- load_mod (eb_info_mod eval_break)
- return
- InternalBreakpointId
- { ibi_tick_mod = tickl
- , ibi_tick_index = eb_tick_index eval_break
- , ibi_info_mod = infol
- , ibi_info_index = eb_info_index eval_break
- }
+evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
+evalBreakpointToId eval_break =
+ let
+ mkUnitId u = RealUnit (Definite $ stringToUnitId u)
+
+ toModule u n = mkModule (mkUnitId u) (mkModuleName n)
+ tickl = toModule (eb_tick_mod_unit eval_break) (eb_tick_mod eval_break)
+ infol = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
+ in
+ InternalBreakpointId
+ { ibi_tick_mod = tickl
+ , ibi_tick_index = eb_tick_index eval_break
+ , ibi_info_mod = infol
+ , ibi_info_index = eb_info_index eval_break
+ }
-- | Process the result of a Seq or ResumeSeq message. #2950
handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())
@@ -447,12 +452,12 @@ handleSeqHValueStatus interp unit_env eval_status =
mkGeneralSrcSpan (fsLit "<unknown>")
Just break -> do
- bi <- evalBreakpointToId (ue_hpt unit_env) break
+ let bi = evalBreakpointToId break
-- Just case: Stopped at a breakpoint, extract SrcSpan information
-- from the breakpoint.
breaks_tick <- getModBreaks . expectJust <$>
- lookupHpt (ue_hpt unit_env) (moduleName (ibi_tick_mod bi))
+ HUG.lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env)
put $ brackets . ppr $
(modBreaks_locs breaks_tick) ! ibi_tick_index bi
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -416,7 +416,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
Nothing -> pure code
Just current_mod_breaks -> break_info hsc_env tick_mod current_mod mb_current_mod_breaks >>= \case
Nothing -> pure code
- Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do
+ Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_module_unitid = tick_mod_id_ptr, modBreaks_ccs = cc_arr} -> do
platform <- profilePlatform <$> getProfile
let idOffSets = getVarOffSets platform d p fvs
ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
@@ -425,6 +425,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty
let info_mod_ptr = modBreaks_module current_mod_breaks
+ info_mod_id_ptr = modBreaks_module_unitid current_mod_breaks
infox <- newBreakInfo breakInfo
let cc | Just interp <- hsc_interp hsc_env
@@ -437,7 +438,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
in if fromIntegral r == x
then r
else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)
- breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc
+ breakInstr = BRK_FUN breaks tick_mod_ptr tick_mod_id_ptr (toW16 tick_no) info_mod_ptr info_mod_id_ptr (toW16 infox) cc
return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -23,6 +23,7 @@ module GHCi.Message
, getMessage, putMessage, getTHMessage, putTHMessage
, Pipe, mkPipeFromHandles, mkPipeFromContinuations, remoteCall, remoteTHCall, readPipe, writePipe
, BreakModule
+ , BreakUnitId
, LoadedDLL
) where
@@ -245,8 +246,9 @@ data Message a where
-- | Allocate a string for a breakpoint module name.
-- This uses an empty dummy type because @ModuleName@ isn't available here.
NewBreakModule
- :: String
- -> Message (RemotePtr BreakModule)
+ :: String -- ^ @ModuleName@
+ -> String -- ^ @UnitId@ for the given @ModuleName@
+ -> Message (RemotePtr BreakModule, RemotePtr BreakUnitId)
deriving instance Show (Message a)
@@ -410,10 +412,12 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_tick_mod :: String -- ^ Breakpoint tick module
- , eb_tick_index :: Int -- ^ Breakpoint tick index
- , eb_info_mod :: String -- ^ Breakpoint info module
- , eb_info_index :: Int -- ^ Breakpoint info index
+ { eb_tick_mod :: String -- ^ Breakpoint tick module
+ , eb_tick_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_tick_index :: Int -- ^ Breakpoint tick index
+ , eb_info_mod :: String -- ^ Breakpoint info module
+ , eb_info_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_info_index :: Int -- ^ Breakpoint info index
}
deriving (Generic, Show)
@@ -430,6 +434,10 @@ instance Binary a => Binary (EvalResult a)
-- that type isn't available here.
data BreakModule
+-- | A dummy type that tags the pointer to a breakpoint's @UnitId@, because
+-- that type isn't available here.
+data BreakUnitId
+
-- | A dummy type that tags pointers returned by 'LoadDLL'.
data LoadedDLL
@@ -580,7 +588,7 @@ getMessage = do
36 -> Msg <$> (Seq <$> get)
37 -> Msg <$> return RtsRevertCAFs
38 -> Msg <$> (ResumeSeq <$> get)
- 39 -> Msg <$> (NewBreakModule <$> get)
+ 39 -> Msg <$> (NewBreakModule <$> get <*> get)
40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
41 -> Msg <$> (WhereFrom <$> get)
_ -> error $ "Unknown Message code " ++ (show b)
@@ -627,7 +635,7 @@ putMessage m = case m of
Seq a -> putWord8 36 >> put a
RtsRevertCAFs -> putWord8 37
ResumeSeq a -> putWord8 38 >> put a
- NewBreakModule name -> putWord8 39 >> put name
+ NewBreakModule name unitid -> putWord8 39 >> put name >> put unitid
LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str
WhereFrom a -> putWord8 41 >> put a
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -95,7 +95,10 @@ run m = case m of
MkCostCentres mod ccs -> mkCostCentres mod ccs
CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
- NewBreakModule name -> newModuleName name
+ NewBreakModule name unitid -> do
+ namePtr <- newModuleName name
+ uidPtr <- newUnitId unitid
+ pure (namePtr, uidPtr)
SetupBreakpoint ref ix cnt -> do
arr <- localRef ref;
_ <- setupBreakpoint arr ix cnt
@@ -335,7 +338,7 @@ withBreakAction opts breakMVar statusMVar act
-- as soon as it is hit, or in resetBreakAction below.
onBreak :: BreakpointCallback
- onBreak tick_mod# tickx# info_mod# infox# is_exception apStack = do
+ onBreak tick_mod# tick_mod_uid# tickx# info_mod# info_mod_uid# infox# is_exception apStack = do
tid <- myThreadId
let resume = ResumeContext
{ resumeBreakMVar = breakMVar
@@ -349,8 +352,10 @@ withBreakAction opts breakMVar statusMVar act
then pure Nothing
else do
tick_mod <- peekCString (Ptr tick_mod#)
+ tick_mod_uid <- peekCString (Ptr tick_mod_uid#)
info_mod <- peekCString (Ptr info_mod#)
- pure (Just (EvalBreakpoint tick_mod (I# tickx#) info_mod (I# infox#)))
+ info_mod_uid <- peekCString (Ptr info_mod_uid#)
+ pure (Just (EvalBreakpoint tick_mod tick_mod_uid (I# tickx#) info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
takeMVar breakMVar
@@ -400,8 +405,10 @@ resetStepFlag = poke stepFlag 0
type BreakpointCallback
= Addr# -- pointer to the breakpoint tick module name
+ -> Addr# -- pointer to the breakpoint tick module unit id
-> Int# -- breakpoint tick index
-> Addr# -- pointer to the breakpoint info module name
+ -> Addr# -- pointer to the breakpoint info module unit id
-> Int# -- breakpoint info index
-> Bool -- exception?
-> HValue -- the AP_STACK, or exception
@@ -414,8 +421,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
noBreakAction :: BreakpointCallback
-noBreakAction _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
-noBreakAction _ _ _ _ True _ = return () -- exception: just continue
+noBreakAction _ _ _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction _ _ _ _ _ _ True _ = return () -- exception: just continue
-- Malloc and copy the bytes. We don't have any way to monitor the
-- lifetime of this memory, so it just leaks.
@@ -453,6 +460,10 @@ newModuleName :: String -> IO (RemotePtr BreakModule)
newModuleName name =
castRemotePtr . toRemotePtr <$> newCString name
+newUnitId :: String -> IO (RemotePtr BreakUnitId)
+newUnitId name =
+ castRemotePtr . toRemotePtr <$> newCString name
+
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
case getApStackVal# apStack stackDepth of
=====================================
rts/Exception.cmm
=====================================
@@ -535,12 +535,16 @@ retry_pop_stack:
// be per-thread.
CInt[rts_stop_on_exception] = 0;
("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr");
- Sp = Sp - WDS(13);
- Sp(12) = exception;
- Sp(11) = stg_raise_ret_info;
- Sp(10) = exception;
- Sp(9) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
- Sp(8) = stg_ap_ppv_info;
+ Sp = Sp - WDS(17);
+ Sp(16) = exception;
+ Sp(15) = stg_raise_ret_info;
+ Sp(14) = exception;
+ Sp(13) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
+ Sp(12) = stg_ap_ppv_info;
+ Sp(11) = 0;
+ Sp(10) = stg_ap_n_info;
+ Sp(9) = 0;
+ Sp(8) = stg_ap_n_info;
Sp(7) = 0;
Sp(6) = stg_ap_n_info;
Sp(5) = 0;
=====================================
rts/Interpreter.c
=====================================
@@ -1245,9 +1245,9 @@ run_BCO:
/* check for a breakpoint on the beginning of a let binding */
case bci_BRK_FUN:
{
- int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_index, arg5_info_index;
+ int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_mod_id, arg5_info_mod_id, arg6_tick_index, arg7_info_index;
#if defined(PROFILING)
- int arg6_cc;
+ int arg8_cc;
#endif
StgArrBytes *breakPoints;
int returning_from_break;
@@ -1264,10 +1264,12 @@ run_BCO:
arg1_brk_array = BCO_GET_LARGE_ARG;
arg2_tick_mod = BCO_GET_LARGE_ARG;
arg3_info_mod = BCO_GET_LARGE_ARG;
- arg4_tick_index = BCO_NEXT;
- arg5_info_index = BCO_NEXT;
+ arg4_tick_mod_id = BCO_GET_LARGE_ARG;
+ arg5_info_mod_id = BCO_GET_LARGE_ARG;
+ arg6_tick_index = BCO_NEXT;
+ arg7_info_index = BCO_NEXT;
#if defined(PROFILING)
- arg6_cc = BCO_GET_LARGE_ARG;
+ arg8_cc = BCO_GET_LARGE_ARG;
#else
BCO_GET_LARGE_ARG;
#endif
@@ -1280,7 +1282,7 @@ run_BCO:
#if defined(PROFILING)
cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
- (CostCentre*)BCO_LIT(arg6_cc));
+ (CostCentre*)BCO_LIT(arg8_cc));
#endif
// if we are returning from a break then skip this section
@@ -1292,11 +1294,11 @@ run_BCO:
// stop the current thread if either the
// "rts_stop_next_breakpoint" flag is true OR if the
// ignore count for this particular breakpoint is zero
- StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_tick_index];
+ StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index];
if (rts_stop_next_breakpoint == false && ignore_count > 0)
{
// decrement and write back ignore count
- ((StgInt*)breakPoints->payload)[arg4_tick_index] = --ignore_count;
+ ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count;
}
else if (rts_stop_next_breakpoint == true || ignore_count == 0)
{
@@ -1330,8 +1332,10 @@ run_BCO:
// continue execution of this BCO when the IO action returns.
//
// ioAction :: Addr# -- the breakpoint tick module
+ // -> Addr# -- the breakpoint tick module unit id
// -> Int# -- the breakpoint tick index
// -> Addr# -- the breakpoint info module
+ // -> Addr# -- the breakpoint info module unit id
// -> Int# -- the breakpoint info index
// -> Bool -- exception?
// -> HValue -- the AP_STACK, or exception
@@ -1340,17 +1344,21 @@ run_BCO:
ioAction = (StgClosure *) deRefStablePtr (
rts_breakpoint_io_action);
- Sp_subW(15);
- SpW(14) = (W_)obj;
- SpW(13) = (W_)&stg_apply_interp_info;
- SpW(12) = (W_)new_aps;
- SpW(11) = (W_)False_closure; // True <=> an exception
- SpW(10) = (W_)&stg_ap_ppv_info;
- SpW(9) = (W_)arg5_info_index;
+ Sp_subW(19);
+ SpW(18) = (W_)obj;
+ SpW(17) = (W_)&stg_apply_interp_info;
+ SpW(16) = (W_)new_aps;
+ SpW(15) = (W_)False_closure; // True <=> an exception
+ SpW(14) = (W_)&stg_ap_ppv_info;
+ SpW(13) = (W_)arg7_info_index;
+ SpW(12) = (W_)&stg_ap_n_info;
+ SpW(11) = (W_)BCO_LIT(arg5_info_mod_id);
+ SpW(10) = (W_)&stg_ap_n_info;
+ SpW(9) = (W_)BCO_LIT(arg3_info_mod);
SpW(8) = (W_)&stg_ap_n_info;
- SpW(7) = (W_)BCO_LIT(arg3_info_mod);
+ SpW(7) = (W_)arg6_tick_index;
SpW(6) = (W_)&stg_ap_n_info;
- SpW(5) = (W_)arg4_tick_index;
+ SpW(5) = (W_)BCO_LIT(arg4_tick_mod_id);
SpW(4) = (W_)&stg_ap_n_info;
SpW(3) = (W_)BCO_LIT(arg2_tick_mod);
SpW(2) = (W_)&stg_ap_n_info;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91cb97034351a26f2162113a877ae27…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91cb97034351a26f2162113a877ae27…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-debugger-unitid] Add `UnitId`` to `EvalBreakpoint`
by Hannes Siebenhandl (＠fendor) 17 Apr '25
by Hannes Siebenhandl (＠fendor) 17 Apr '25
17 Apr '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-debugger-unitid at Glasgow Haskell Compiler / GHC
Commits:
31e01836 by fendor at 2025-04-17T14:22:27+02:00
Add `UnitId`` to `EvalBreakpoint`
The `EvalBreakpoint` is used to communicate that a breakpoint was
encountered during code evaluation.
This `EvalBreakpoint` needs to be converted to an `InternalBreakpointId`
which stores a `Module` to uniquely find the correct `Module` in the
Home Package Table.
The `EvalBreakpoint` used to store only a `ModuleName` which is then
converted to a `Module` based on the currently active home unit.
This is incorrect in the face of multiple home units, the break point
could be in an entirely other home unit!
To fix this, we additionally store the `UnitId` of the `Module` in
`EvalBreakpoint` to later reconstruct the correct `Module`
All of the changes are the consequence of extending `EvalBreakpoint`
with the additional `UnitId`.
- - - - -
11 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Exception.cmm
- rts/Interpreter.c
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -732,13 +732,16 @@ assembleI platform i = case i of
CCALL off m_addr i -> do np <- addr m_addr
emit_ bci_CCALL [wOp off, Op np, SmallOp i]
PRIMCALL -> emit_ bci_PRIMCALL []
- BRK_FUN arr tick_mod tickx info_mod infox cc ->
+ BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc ->
do p1 <- ptr (BCOPtrBreakArray arr)
tick_addr <- addr tick_mod
+ tick_unitid_addr <- addr tick_mod_id
info_addr <- addr info_mod
+ info_unitid_addr <- addr info_mod_id
np <- addr cc
emit_ bci_BRK_FUN [ Op p1
, Op tick_addr, Op info_addr
+ , Op tick_unitid_addr, Op info_unitid_addr
, SmallOp tickx, SmallOp infox
, Op np
]
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Stg.Syntax
import GHCi.BreakArray (BreakArray)
import Language.Haskell.Syntax.Module.Name (ModuleName)
import GHC.Types.Unique
+import GHC.Unit.Types (UnitId)
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -233,8 +234,10 @@ data BCInstr
-- Breakpoints
| BRK_FUN (ForeignRef BreakArray)
(RemotePtr ModuleName) -- breakpoint tick module
+ (RemotePtr UnitId) -- breakpoint tick module unit id
!Word16 -- breakpoint tick index
(RemotePtr ModuleName) -- breakpoint info module
+ (RemotePtr UnitId) -- breakpoint info module unit id
!Word16 -- breakpoint info index
(RemotePtr CostCentre)
@@ -403,10 +406,10 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk
ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
- ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)
+ ppr (BRK_FUN _ _tick_mod _tick_mod_id tickx _info_mod _info_mod_id infox _)
= text "BRK_FUN" <+> text "<breakarray>"
- <+> text "<tick_module>" <+> ppr tickx
- <+> text "<info_module>" <+> ppr infox
+ <+> text "<tick_module>" <+> text "<tick_module_unitid>" <+> ppr tickx
+ <+> text "<info_module>" <+> text "<info_module_unitid>" <+> ppr infox
<+> text "<cc>"
#if MIN_VERSION_rts(1,0,3)
ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm)
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -50,6 +50,7 @@ import GHC.Stack.CCS
import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
import GHC.Iface.Syntax
import Language.Haskell.Syntax.Module.Name (ModuleName)
+import GHC.Unit.Types (UnitId)
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -263,6 +264,9 @@ data ModBreaks
, modBreaks_breakInfo :: IntMap CgBreakInfo
-- ^ info about each breakpoint from the bytecode generator
, modBreaks_module :: RemotePtr ModuleName
+ -- ^ info about the module in which we are setting the breakpoint
+ , modBreaks_module_unitid :: RemotePtr UnitId
+ -- ^ The 'UnitId' of the 'ModuleName'
}
seqModBreaks :: ModBreaks -> ()
@@ -273,7 +277,8 @@ seqModBreaks ModBreaks{..} =
rnf modBreaks_decls `seq`
rnf modBreaks_ccs `seq`
rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq`
- rnf modBreaks_module
+ rnf modBreaks_module `seq`
+ rnf modBreaks_module_unitid
-- | Construct an empty ModBreaks
emptyModBreaks :: ModBreaks
@@ -286,6 +291,7 @@ emptyModBreaks = ModBreaks
, modBreaks_ccs = array (0,-1) []
, modBreaks_breakInfo = IntMap.empty
, modBreaks_module = toRemotePtr nullPtr
+ , modBreaks_module_unitid = toRemotePtr nullPtr
}
{-
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -34,7 +34,7 @@ mkModBreaks interp mod extendedMixEntries
breakArray <- GHCi.newBreakArray interp count
ccs <- mkCCSArray interp mod count entries
- mod_ptr <- GHCi.newModuleName interp (moduleName mod)
+ (mod_ptr, mod_id_ptr) <- GHCi.newModule interp mod
let
locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
@@ -46,6 +46,7 @@ mkModBreaks interp mod extendedMixEntries
, modBreaks_decls = declsTicks
, modBreaks_ccs = ccs
, modBreaks_module = mod_ptr
+ , modBreaks_module_unitid = mod_id_ptr
}
mkCCSArray
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -345,7 +345,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
-- Just case: we stopped at a breakpoint
EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
- ibi <- liftIO $ evalBreakpointToId (hsc_HPT hsc_env) eval_break
+ let ibi = evalBreakpointToId eval_break
tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi)
let
span = modBreaks_locs tick_brks ! ibi_tick_index ibi
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Runtime.Interpreter
, mkCostCentres
, costCentreStackInfo
, newBreakArray
- , newModuleName
+ , newModule
, storeBreakpoint
, breakpointStatus
, getBreakpointVar
@@ -93,9 +93,7 @@ import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe)
import GHC.Utils.Fingerprint
import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
import GHC.Unit.Home.ModInfo
-import GHC.Unit.Home.PackageTable
import GHC.Unit.Env
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -119,6 +117,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
@@ -377,9 +376,13 @@ newBreakArray interp size = do
breakArray <- interpCmd interp (NewBreakArray size)
mkFinalizedHValue interp breakArray
-newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)
-newModuleName interp mod_name =
- castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name))
+newModule :: Interp -> Module -> IO (RemotePtr ModuleName, RemotePtr UnitId)
+newModule interp mod = do
+ let
+ mod_name = moduleNameString $ moduleName mod
+ mod_id = unitIdString $ toUnitId $ moduleUnit mod
+ (mod_ptr, mod_id_ptr) <- interpCmd interp (NewBreakModule mod_name mod_id)
+ pure (castRemotePtr mod_ptr, castRemotePtr mod_id_ptr)
storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()
storeBreakpoint interp ref ix cnt = do -- #19157
@@ -415,19 +418,21 @@ seqHValue interp unit_env ref =
status <- interpCmd interp (Seq hval)
handleSeqHValueStatus interp unit_env status
-evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> IO InternalBreakpointId
-evalBreakpointToId hpt eval_break =
- let load_mod x = mi_module . hm_iface . expectJust <$> lookupHpt hpt (mkModuleName x)
- in do
- tickl <- load_mod (eb_tick_mod eval_break)
- infol <- load_mod (eb_info_mod eval_break)
- return
- InternalBreakpointId
- { ibi_tick_mod = tickl
- , ibi_tick_index = eb_tick_index eval_break
- , ibi_info_mod = infol
- , ibi_info_index = eb_info_index eval_break
- }
+evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
+evalBreakpointToId eval_break =
+ let
+ mkUnitId u = RealUnit (Definite $ stringToUnitId u)
+
+ toModule u n = mkModule (mkUnitId u) (mkModuleName n)
+ tickl = toModule (eb_tick_mod_unit eval_break) (eb_tick_mod eval_break)
+ infol = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
+ in
+ InternalBreakpointId
+ { ibi_tick_mod = tickl
+ , ibi_tick_index = eb_tick_index eval_break
+ , ibi_info_mod = infol
+ , ibi_info_index = eb_info_index eval_break
+ }
-- | Process the result of a Seq or ResumeSeq message. #2950
handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())
@@ -447,12 +452,12 @@ handleSeqHValueStatus interp unit_env eval_status =
mkGeneralSrcSpan (fsLit "<unknown>")
Just break -> do
- bi <- evalBreakpointToId (ue_hpt unit_env) break
+ let bi = evalBreakpointToId break
-- Just case: Stopped at a breakpoint, extract SrcSpan information
-- from the breakpoint.
breaks_tick <- getModBreaks . expectJust <$>
- lookupHpt (ue_hpt unit_env) (moduleName (ibi_tick_mod bi))
+ HUG.lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env)
put $ brackets . ppr $
(modBreaks_locs breaks_tick) ! ibi_tick_index bi
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -416,7 +416,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
Nothing -> pure code
Just current_mod_breaks -> break_info hsc_env tick_mod current_mod mb_current_mod_breaks >>= \case
Nothing -> pure code
- Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do
+ Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_module_unitid = tick_mod_id_ptr, modBreaks_ccs = cc_arr} -> do
platform <- profilePlatform <$> getProfile
let idOffSets = getVarOffSets platform d p fvs
ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
@@ -425,6 +425,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty
let info_mod_ptr = modBreaks_module current_mod_breaks
+ info_mod_id_ptr = modBreaks_module_unitid current_mod_breaks
infox <- newBreakInfo breakInfo
let cc | Just interp <- hsc_interp hsc_env
@@ -437,7 +438,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
in if fromIntegral r == x
then r
else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)
- breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc
+ breakInstr = BRK_FUN breaks tick_mod_ptr tick_mod_id_ptr (toW16 tick_no) info_mod_ptr info_mod_id_ptr (toW16 infox) cc
return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -23,6 +23,7 @@ module GHCi.Message
, getMessage, putMessage, getTHMessage, putTHMessage
, Pipe, mkPipeFromHandles, mkPipeFromContinuations, remoteCall, remoteTHCall, readPipe, writePipe
, BreakModule
+ , BreakUnitId
, LoadedDLL
) where
@@ -245,8 +246,9 @@ data Message a where
-- | Allocate a string for a breakpoint module name.
-- This uses an empty dummy type because @ModuleName@ isn't available here.
NewBreakModule
- :: String
- -> Message (RemotePtr BreakModule)
+ :: String -- ^ @ModuleName@
+ -> String -- ^ @UnitId@ for the given @ModuleName@
+ -> Message (RemotePtr BreakModule, RemotePtr BreakUnitId)
deriving instance Show (Message a)
@@ -410,10 +412,12 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_tick_mod :: String -- ^ Breakpoint tick module
- , eb_tick_index :: Int -- ^ Breakpoint tick index
- , eb_info_mod :: String -- ^ Breakpoint info module
- , eb_info_index :: Int -- ^ Breakpoint info index
+ { eb_tick_mod :: String -- ^ Breakpoint tick module
+ , eb_tick_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_tick_index :: Int -- ^ Breakpoint tick index
+ , eb_info_mod :: String -- ^ Breakpoint info module
+ , eb_info_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_info_index :: Int -- ^ Breakpoint info index
}
deriving (Generic, Show)
@@ -430,6 +434,10 @@ instance Binary a => Binary (EvalResult a)
-- that type isn't available here.
data BreakModule
+-- | A dummy type that tags the pointer to a breakpoint's @UnitId@, because
+-- that type isn't available here.
+data BreakUnitId
+
-- | A dummy type that tags pointers returned by 'LoadDLL'.
data LoadedDLL
@@ -580,7 +588,7 @@ getMessage = do
36 -> Msg <$> (Seq <$> get)
37 -> Msg <$> return RtsRevertCAFs
38 -> Msg <$> (ResumeSeq <$> get)
- 39 -> Msg <$> (NewBreakModule <$> get)
+ 39 -> Msg <$> (NewBreakModule <$> get <*> get)
40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
41 -> Msg <$> (WhereFrom <$> get)
_ -> error $ "Unknown Message code " ++ (show b)
@@ -627,7 +635,7 @@ putMessage m = case m of
Seq a -> putWord8 36 >> put a
RtsRevertCAFs -> putWord8 37
ResumeSeq a -> putWord8 38 >> put a
- NewBreakModule name -> putWord8 39 >> put name
+ NewBreakModule name unitid -> putWord8 39 >> put name >> put unitid
LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str
WhereFrom a -> putWord8 41 >> put a
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -95,7 +95,10 @@ run m = case m of
MkCostCentres mod ccs -> mkCostCentres mod ccs
CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
- NewBreakModule name -> newModuleName name
+ NewBreakModule name unitid -> do
+ namePtr <- newModuleName name
+ uidPtr <- newUnitId unitid
+ pure (namePtr, uidPtr)
SetupBreakpoint ref ix cnt -> do
arr <- localRef ref;
_ <- setupBreakpoint arr ix cnt
@@ -335,7 +338,7 @@ withBreakAction opts breakMVar statusMVar act
-- as soon as it is hit, or in resetBreakAction below.
onBreak :: BreakpointCallback
- onBreak tick_mod# tickx# info_mod# infox# is_exception apStack = do
+ onBreak tick_mod# tick_mod_uid# tickx# info_mod# info_mod_uid# infox# is_exception apStack = do
tid <- myThreadId
let resume = ResumeContext
{ resumeBreakMVar = breakMVar
@@ -349,8 +352,10 @@ withBreakAction opts breakMVar statusMVar act
then pure Nothing
else do
tick_mod <- peekCString (Ptr tick_mod#)
+ tick_mod_uid <- peekCString (Ptr tick_mod_uid#)
info_mod <- peekCString (Ptr info_mod#)
- pure (Just (EvalBreakpoint tick_mod (I# tickx#) info_mod (I# infox#)))
+ info_mod_uid <- peekCString (Ptr info_mod_uid#)
+ pure (Just (EvalBreakpoint tick_mod tick_mod_uid (I# tickx#) info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
takeMVar breakMVar
@@ -400,8 +405,10 @@ resetStepFlag = poke stepFlag 0
type BreakpointCallback
= Addr# -- pointer to the breakpoint tick module name
+ -> Addr# -- pointer to the breakpoint tick module unit id
-> Int# -- breakpoint tick index
-> Addr# -- pointer to the breakpoint info module name
+ -> Addr# -- pointer to the breakpoint info module unit id
-> Int# -- breakpoint info index
-> Bool -- exception?
-> HValue -- the AP_STACK, or exception
@@ -414,8 +421,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
noBreakAction :: BreakpointCallback
-noBreakAction _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
-noBreakAction _ _ _ _ True _ = return () -- exception: just continue
+noBreakAction _ _ _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction _ _ _ _ _ _ True _ = return () -- exception: just continue
-- Malloc and copy the bytes. We don't have any way to monitor the
-- lifetime of this memory, so it just leaks.
@@ -453,6 +460,10 @@ newModuleName :: String -> IO (RemotePtr BreakModule)
newModuleName name =
castRemotePtr . toRemotePtr <$> newCString name
+newUnitId :: String -> IO (RemotePtr BreakUnitId)
+newUnitId name =
+ castRemotePtr . toRemotePtr <$> newCString name
+
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
case getApStackVal# apStack stackDepth of
=====================================
rts/Exception.cmm
=====================================
@@ -535,12 +535,16 @@ retry_pop_stack:
// be per-thread.
CInt[rts_stop_on_exception] = 0;
("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr");
- Sp = Sp - WDS(13);
- Sp(12) = exception;
- Sp(11) = stg_raise_ret_info;
- Sp(10) = exception;
- Sp(9) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
- Sp(8) = stg_ap_ppv_info;
+ Sp = Sp - WDS(17);
+ Sp(16) = exception;
+ Sp(15) = stg_raise_ret_info;
+ Sp(14) = exception;
+ Sp(13) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
+ Sp(12) = stg_ap_ppv_info;
+ Sp(11) = 0;
+ Sp(10) = stg_ap_n_info;
+ Sp(9) = 0;
+ Sp(8) = stg_ap_n_info;
Sp(7) = 0;
Sp(6) = stg_ap_n_info;
Sp(5) = 0;
=====================================
rts/Interpreter.c
=====================================
@@ -1245,9 +1245,9 @@ run_BCO:
/* check for a breakpoint on the beginning of a let binding */
case bci_BRK_FUN:
{
- int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_index, arg5_info_index;
+ int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_mod_id, arg5_info_mod_id, arg6_tick_index, arg7_info_index;
#if defined(PROFILING)
- int arg6_cc;
+ int arg8_cc;
#endif
StgArrBytes *breakPoints;
int returning_from_break;
@@ -1264,10 +1264,12 @@ run_BCO:
arg1_brk_array = BCO_GET_LARGE_ARG;
arg2_tick_mod = BCO_GET_LARGE_ARG;
arg3_info_mod = BCO_GET_LARGE_ARG;
- arg4_tick_index = BCO_NEXT;
- arg5_info_index = BCO_NEXT;
+ arg4_tick_mod_id = BCO_GET_LARGE_ARG;
+ arg5_info_mod_id = BCO_GET_LARGE_ARG;
+ arg6_tick_index = BCO_NEXT;
+ arg7_info_index = BCO_NEXT;
#if defined(PROFILING)
- arg6_cc = BCO_GET_LARGE_ARG;
+ arg8_cc = BCO_GET_LARGE_ARG;
#else
BCO_GET_LARGE_ARG;
#endif
@@ -1280,7 +1282,7 @@ run_BCO:
#if defined(PROFILING)
cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
- (CostCentre*)BCO_LIT(arg6_cc));
+ (CostCentre*)BCO_LIT(arg8_cc));
#endif
// if we are returning from a break then skip this section
@@ -1292,11 +1294,11 @@ run_BCO:
// stop the current thread if either the
// "rts_stop_next_breakpoint" flag is true OR if the
// ignore count for this particular breakpoint is zero
- StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_tick_index];
+ StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index];
if (rts_stop_next_breakpoint == false && ignore_count > 0)
{
// decrement and write back ignore count
- ((StgInt*)breakPoints->payload)[arg4_tick_index] = --ignore_count;
+ ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count;
}
else if (rts_stop_next_breakpoint == true || ignore_count == 0)
{
@@ -1330,8 +1332,10 @@ run_BCO:
// continue execution of this BCO when the IO action returns.
//
// ioAction :: Addr# -- the breakpoint tick module
+ // -> Addr# -- the breakpoint tick module unit id
// -> Int# -- the breakpoint tick index
// -> Addr# -- the breakpoint info module
+ // -> Addr# -- the breakpoint info module unit id
// -> Int# -- the breakpoint info index
// -> Bool -- exception?
// -> HValue -- the AP_STACK, or exception
@@ -1340,17 +1344,21 @@ run_BCO:
ioAction = (StgClosure *) deRefStablePtr (
rts_breakpoint_io_action);
- Sp_subW(15);
- SpW(14) = (W_)obj;
- SpW(13) = (W_)&stg_apply_interp_info;
- SpW(12) = (W_)new_aps;
- SpW(11) = (W_)False_closure; // True <=> an exception
- SpW(10) = (W_)&stg_ap_ppv_info;
- SpW(9) = (W_)arg5_info_index;
+ Sp_subW(19);
+ SpW(18) = (W_)obj;
+ SpW(17) = (W_)&stg_apply_interp_info;
+ SpW(16) = (W_)new_aps;
+ SpW(15) = (W_)False_closure; // True <=> an exception
+ SpW(14) = (W_)&stg_ap_ppv_info;
+ SpW(13) = (W_)arg7_info_index;
+ SpW(12) = (W_)&stg_ap_n_info;
+ SpW(11) = (W_)BCO_LIT(arg5_info_mod_id);
+ SpW(10) = (W_)&stg_ap_n_info;
+ SpW(9) = (W_)BCO_LIT(arg3_info_mod);
SpW(8) = (W_)&stg_ap_n_info;
- SpW(7) = (W_)BCO_LIT(arg3_info_mod);
+ SpW(7) = (W_)arg6_tick_index;
SpW(6) = (W_)&stg_ap_n_info;
- SpW(5) = (W_)arg4_tick_index;
+ SpW(5) = (W_)BCO_LIT(arg4_tick_mod_id);
SpW(4) = (W_)&stg_ap_n_info;
SpW(3) = (W_)BCO_LIT(arg2_tick_mod);
SpW(2) = (W_)&stg_ap_n_info;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31e01836fd194e369a73a0f287c58fb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31e01836fd194e369a73a0f287c58fb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC
Commits:
bc27b6c9 by Simon Peyton Jones at 2025-04-17T13:12:48+01:00
More eperiments
* Don't inline toplevel things so much
* Don't float constants so vigorously in the first float-out
- - - - -
3 changed files:
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1096,14 +1096,14 @@ mkNonRecRhsCtxt lvl bndr unf
certainly_inline -- See Note [Cascading inlines]
= -- mkNonRecRhsCtxt is only used for non-join points, so occAnalBind
-- has set the OccInfo for this binder before calling occAnalNonRecRhs
+ -- Distressing delicacy ... has to line up with preInlineUnconditionally
case idOccInfo bndr of
OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }
- -> active && not stable_unf && not top_bottoming
+ -> active && not (isTopLevel lvl) && not stable_unf
_ -> False
active = isAlwaysActive (idInlineActivation bndr)
stable_unf = isStableUnfolding unf
- top_bottoming = isTopLevel lvl && isDeadEndId bndr
-----------------
occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -217,7 +217,7 @@ getCoreToDo dflags hpt_rule_base extra_vars
if full_laziness then
CoreDoFloatOutwards $ FloatOutSwitches
{ floatOutLambdas = Just 0
- , floatOutConstants = True
+ , floatOutConstants = False -- Initially
, floatOutOverSatApps = False
, floatToTopLevelOnly = False
, floatJoinsToTop = False -- Initially, don't float join points at all
@@ -284,7 +284,7 @@ getCoreToDo dflags hpt_rule_base extra_vars
-- f_el22 (f_el21 r_midblock)
runWhen full_laziness $ CoreDoFloatOutwards $ FloatOutSwitches
{ floatOutLambdas = floatLamArgs dflags
- , floatOutConstants = True
+ , floatOutConstants = True -- For SpecConstr and CSE
, floatOutOverSatApps = True
, floatToTopLevelOnly = False
, floatJoinsToTop = True },
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1461,12 +1461,18 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
one_occ IAmDead = True -- Happens in ((\x.1) v)
- one_occ OneOcc{ occ_n_br = 1
- , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase
+ one_occ OneOcc{ occ_n_br = 1
+ , occ_in_lam = NotInsideLam
+ , occ_int_cxt = int_cxt }
+ = isNotTopLevel top_lvl -- Get rid of allocation
+ || (int_cxt==IsInteresting) -- Function is applied
+ || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase
one_occ OneOcc{ occ_n_br = 1
, occ_in_lam = IsInsideLam
- , occ_int_cxt = IsInteresting } = canInlineInLam rhs
- one_occ _ = False
+ , occ_int_cxt = IsInteresting }
+ = canInlineInLam rhs
+ one_occ _
+ = False
pre_inline_unconditionally = sePreInline env
active = isActive (sePhase env) (inlinePragmaActivation inline_prag)
@@ -1641,9 +1647,10 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs
| otherwise = smallEnoughToInline uf_opts unfolding
-- See Note [Post-inline for single-use things]
- check_one_occ NotInsideLam _ n_br = code_dup_ok n_br
- check_one_occ IsInsideLam NotInteresting _ = False
- check_one_occ IsInsideLam IsInteresting n_br = is_cheap && code_dup_ok n_br
+ check_one_occ NotInsideLam NotInteresting n_br = not is_top_lvl && code_dup_ok n_br
+ check_one_occ NotInsideLam IsInteresting n_br = code_dup_ok n_br
+ check_one_occ IsInsideLam NotInteresting _ = False
+ check_one_occ IsInsideLam IsInteresting n_br = is_cheap && code_dup_ok n_br
-- IsInteresting: inlining inside a lambda only with good reason
-- See the notes on int_cxt in preInlineUnconditionally
-- is_cheap: check for acceptable work duplication, using isCheapUnfolding
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc27b6c9b536a8200cd2b8750e4744f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc27b6c9b536a8200cd2b8750e4744f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/fendor/ghci-debugger-unitid
by Hannes Siebenhandl (＠fendor) 17 Apr '25
by Hannes Siebenhandl (＠fendor) 17 Apr '25
17 Apr '25
Hannes Siebenhandl pushed new branch wip/fendor/ghci-debugger-unitid at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/ghci-debugger-unitid
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units-with-debugger] Make GHCi debugger compatible with multiple home units
by Hannes Siebenhandl (＠fendor) 17 Apr '25
by Hannes Siebenhandl (＠fendor) 17 Apr '25
17 Apr '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units-with-debugger at Glasgow Haskell Compiler / GHC
Commits:
f071532b by fendor at 2025-04-17T13:33:14+02:00
Make GHCi debugger compatible with multiple home units
FIXME: proper commit message
- - - - -
11 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Exception.cmm
- rts/Interpreter.c
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -732,13 +732,16 @@ assembleI platform i = case i of
CCALL off m_addr i -> do np <- addr m_addr
emit_ bci_CCALL [wOp off, Op np, SmallOp i]
PRIMCALL -> emit_ bci_PRIMCALL []
- BRK_FUN arr tick_mod tickx info_mod infox cc ->
+ BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc ->
do p1 <- ptr (BCOPtrBreakArray arr)
tick_addr <- addr tick_mod
+ tick_unitid_addr <- addr tick_mod_id
info_addr <- addr info_mod
+ info_unitid_addr <- addr info_mod_id
np <- addr cc
emit_ bci_BRK_FUN [ Op p1
, Op tick_addr, Op info_addr
+ , Op tick_unitid_addr, Op info_unitid_addr
, SmallOp tickx, SmallOp infox
, Op np
]
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Stg.Syntax
import GHCi.BreakArray (BreakArray)
import Language.Haskell.Syntax.Module.Name (ModuleName)
import GHC.Types.Unique
+import GHC.Unit.Types (UnitId)
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -233,8 +234,10 @@ data BCInstr
-- Breakpoints
| BRK_FUN (ForeignRef BreakArray)
(RemotePtr ModuleName) -- breakpoint tick module
+ (RemotePtr UnitId) -- breakpoint tick module unit id
!Word16 -- breakpoint tick index
(RemotePtr ModuleName) -- breakpoint info module
+ (RemotePtr UnitId) -- breakpoint info module unit id
!Word16 -- breakpoint info index
(RemotePtr CostCentre)
@@ -403,10 +406,10 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk
ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
- ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)
+ ppr (BRK_FUN _ _tick_mod _tick_mod_id tickx _info_mod _info_mod_id infox _)
= text "BRK_FUN" <+> text "<breakarray>"
- <+> text "<tick_module>" <+> ppr tickx
- <+> text "<info_module>" <+> ppr infox
+ <+> text "<tick_module>" <+> text "<tick_module_unitid>" <+> ppr tickx
+ <+> text "<info_module>" <+> text "<info_module_unitid>" <+> ppr infox
<+> text "<cc>"
#if MIN_VERSION_rts(1,0,3)
ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm)
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -50,6 +50,7 @@ import GHC.Stack.CCS
import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )
import GHC.Iface.Syntax
import Language.Haskell.Syntax.Module.Name (ModuleName)
+import GHC.Unit.Types (UnitId)
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
@@ -263,6 +264,9 @@ data ModBreaks
, modBreaks_breakInfo :: IntMap CgBreakInfo
-- ^ info about each breakpoint from the bytecode generator
, modBreaks_module :: RemotePtr ModuleName
+ -- ^ info about the module in which we are setting the breakpoint
+ , modBreaks_module_unitid :: RemotePtr UnitId
+ -- ^ The 'UnitId' of the 'ModuleName'
}
seqModBreaks :: ModBreaks -> ()
@@ -273,7 +277,8 @@ seqModBreaks ModBreaks{..} =
rnf modBreaks_decls `seq`
rnf modBreaks_ccs `seq`
rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq`
- rnf modBreaks_module
+ rnf modBreaks_module `seq`
+ rnf modBreaks_module_unitid
-- | Construct an empty ModBreaks
emptyModBreaks :: ModBreaks
@@ -286,6 +291,7 @@ emptyModBreaks = ModBreaks
, modBreaks_ccs = array (0,-1) []
, modBreaks_breakInfo = IntMap.empty
, modBreaks_module = toRemotePtr nullPtr
+ , modBreaks_module_unitid = toRemotePtr nullPtr
}
{-
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -34,7 +34,7 @@ mkModBreaks interp mod extendedMixEntries
breakArray <- GHCi.newBreakArray interp count
ccs <- mkCCSArray interp mod count entries
- mod_ptr <- GHCi.newModuleName interp (moduleName mod)
+ (mod_ptr, mod_id_ptr) <- GHCi.newModule interp mod
let
locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
@@ -46,6 +46,7 @@ mkModBreaks interp mod extendedMixEntries
, modBreaks_decls = declsTicks
, modBreaks_ccs = ccs
, modBreaks_module = mod_ptr
+ , modBreaks_module_unitid = mod_id_ptr
}
mkCCSArray
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -345,7 +345,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
-- Just case: we stopped at a breakpoint
EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
- ibi <- liftIO $ evalBreakpointToId (hsc_HPT hsc_env) eval_break
+ let ibi = evalBreakpointToId eval_break
tick_brks <- liftIO $ readModBreaks hsc_env (ibi_tick_mod ibi)
let
span = modBreaks_locs tick_brks ! ibi_tick_index ibi
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Runtime.Interpreter
, mkCostCentres
, costCentreStackInfo
, newBreakArray
- , newModuleName
+ , newModule
, storeBreakpoint
, breakpointStatus
, getBreakpointVar
@@ -93,9 +93,7 @@ import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe)
import GHC.Utils.Fingerprint
import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
import GHC.Unit.Home.ModInfo
-import GHC.Unit.Home.PackageTable
import GHC.Unit.Env
#if defined(HAVE_INTERNAL_INTERPRETER)
@@ -119,6 +117,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
@@ -377,9 +376,13 @@ newBreakArray interp size = do
breakArray <- interpCmd interp (NewBreakArray size)
mkFinalizedHValue interp breakArray
-newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName)
-newModuleName interp mod_name =
- castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name))
+newModule :: Interp -> Module -> IO (RemotePtr ModuleName, RemotePtr UnitId)
+newModule interp mod = do
+ let
+ mod_name = moduleNameString $ moduleName mod
+ mod_id = unitIdString $ toUnitId $ moduleUnit mod
+ (mod_ptr, mod_id_ptr) <- interpCmd interp (NewBreakModule mod_name mod_id)
+ pure (castRemotePtr mod_ptr, castRemotePtr mod_id_ptr)
storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()
storeBreakpoint interp ref ix cnt = do -- #19157
@@ -415,19 +418,21 @@ seqHValue interp unit_env ref =
status <- interpCmd interp (Seq hval)
handleSeqHValueStatus interp unit_env status
-evalBreakpointToId :: HomePackageTable -> EvalBreakpoint -> IO InternalBreakpointId
-evalBreakpointToId hpt eval_break =
- let load_mod x = mi_module . hm_iface . expectJust <$> lookupHpt hpt (mkModuleName x)
- in do
- tickl <- load_mod (eb_tick_mod eval_break)
- infol <- load_mod (eb_info_mod eval_break)
- return
- InternalBreakpointId
- { ibi_tick_mod = tickl
- , ibi_tick_index = eb_tick_index eval_break
- , ibi_info_mod = infol
- , ibi_info_index = eb_info_index eval_break
- }
+evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
+evalBreakpointToId eval_break =
+ let
+ mkUnitId u = RealUnit (Definite $ stringToUnitId u)
+
+ toModule u n = mkModule (mkUnitId u) (mkModuleName n)
+ tickl = toModule (eb_tick_mod_unit eval_break) (eb_tick_mod eval_break)
+ infol = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
+ in
+ InternalBreakpointId
+ { ibi_tick_mod = tickl
+ , ibi_tick_index = eb_tick_index eval_break
+ , ibi_info_mod = infol
+ , ibi_info_index = eb_info_index eval_break
+ }
-- | Process the result of a Seq or ResumeSeq message. #2950
handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())
@@ -447,12 +452,12 @@ handleSeqHValueStatus interp unit_env eval_status =
mkGeneralSrcSpan (fsLit "<unknown>")
Just break -> do
- bi <- evalBreakpointToId (ue_hpt unit_env) break
+ let bi = evalBreakpointToId break
-- Just case: Stopped at a breakpoint, extract SrcSpan information
-- from the breakpoint.
breaks_tick <- getModBreaks . expectJust <$>
- lookupHpt (ue_hpt unit_env) (moduleName (ibi_tick_mod bi))
+ HUG.lookupHugByModule (ibi_tick_mod bi) (ue_home_unit_graph unit_env)
put $ brackets . ppr $
(modBreaks_locs breaks_tick) ! ibi_tick_index bi
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -416,7 +416,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
Nothing -> pure code
Just current_mod_breaks -> break_info hsc_env tick_mod current_mod mb_current_mod_breaks >>= \case
Nothing -> pure code
- Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_ccs = cc_arr} -> do
+ Just ModBreaks {modBreaks_flags = breaks, modBreaks_module = tick_mod_ptr, modBreaks_module_unitid = tick_mod_id_ptr, modBreaks_ccs = cc_arr} -> do
platform <- profilePlatform <$> getProfile
let idOffSets = getVarOffSets platform d p fvs
ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
@@ -425,6 +425,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty
let info_mod_ptr = modBreaks_module current_mod_breaks
+ info_mod_id_ptr = modBreaks_module_unitid current_mod_breaks
infox <- newBreakInfo breakInfo
let cc | Just interp <- hsc_interp hsc_env
@@ -437,7 +438,7 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs tick_mod) rhs) = do
in if fromIntegral r == x
then r
else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr x)
- breakInstr = BRK_FUN breaks tick_mod_ptr (toW16 tick_no) info_mod_ptr (toW16 infox) cc
+ breakInstr = BRK_FUN breaks tick_mod_ptr tick_mod_id_ptr (toW16 tick_no) info_mod_ptr info_mod_id_ptr (toW16 infox) cc
return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -23,6 +23,7 @@ module GHCi.Message
, getMessage, putMessage, getTHMessage, putTHMessage
, Pipe, mkPipeFromHandles, mkPipeFromContinuations, remoteCall, remoteTHCall, readPipe, writePipe
, BreakModule
+ , BreakUnitId
, LoadedDLL
) where
@@ -245,8 +246,9 @@ data Message a where
-- | Allocate a string for a breakpoint module name.
-- This uses an empty dummy type because @ModuleName@ isn't available here.
NewBreakModule
- :: String
- -> Message (RemotePtr BreakModule)
+ :: String -- ^ @ModuleName@
+ -> String -- ^ @UnitId@ for the given @ModuleName@
+ -> Message (RemotePtr BreakModule, RemotePtr BreakUnitId)
deriving instance Show (Message a)
@@ -410,10 +412,12 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_tick_mod :: String -- ^ Breakpoint tick module
- , eb_tick_index :: Int -- ^ Breakpoint tick index
- , eb_info_mod :: String -- ^ Breakpoint info module
- , eb_info_index :: Int -- ^ Breakpoint info index
+ { eb_tick_mod :: String -- ^ Breakpoint tick module
+ , eb_tick_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_tick_index :: Int -- ^ Breakpoint tick index
+ , eb_info_mod :: String -- ^ Breakpoint info module
+ , eb_info_mod_unit :: String -- ^ Breakpoint tick module unit id
+ , eb_info_index :: Int -- ^ Breakpoint info index
}
deriving (Generic, Show)
@@ -430,6 +434,10 @@ instance Binary a => Binary (EvalResult a)
-- that type isn't available here.
data BreakModule
+-- | A dummy type that tags the pointer to a breakpoint's @UnitId@, because
+-- that type isn't available here.
+data BreakUnitId
+
-- | A dummy type that tags pointers returned by 'LoadDLL'.
data LoadedDLL
@@ -580,7 +588,7 @@ getMessage = do
36 -> Msg <$> (Seq <$> get)
37 -> Msg <$> return RtsRevertCAFs
38 -> Msg <$> (ResumeSeq <$> get)
- 39 -> Msg <$> (NewBreakModule <$> get)
+ 39 -> Msg <$> (NewBreakModule <$> get <*> get)
40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
41 -> Msg <$> (WhereFrom <$> get)
_ -> error $ "Unknown Message code " ++ (show b)
@@ -627,7 +635,7 @@ putMessage m = case m of
Seq a -> putWord8 36 >> put a
RtsRevertCAFs -> putWord8 37
ResumeSeq a -> putWord8 38 >> put a
- NewBreakModule name -> putWord8 39 >> put name
+ NewBreakModule name unitid -> putWord8 39 >> put name >> put unitid
LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str
WhereFrom a -> putWord8 41 >> put a
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -95,7 +95,10 @@ run m = case m of
MkCostCentres mod ccs -> mkCostCentres mod ccs
CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
- NewBreakModule name -> newModuleName name
+ NewBreakModule name unitid -> do
+ namePtr <- newModuleName name
+ uidPtr <- newUnitId unitid
+ pure (namePtr, uidPtr)
SetupBreakpoint ref ix cnt -> do
arr <- localRef ref;
_ <- setupBreakpoint arr ix cnt
@@ -335,7 +338,7 @@ withBreakAction opts breakMVar statusMVar act
-- as soon as it is hit, or in resetBreakAction below.
onBreak :: BreakpointCallback
- onBreak tick_mod# tickx# info_mod# infox# is_exception apStack = do
+ onBreak tick_mod# tick_mod_uid# tickx# info_mod# info_mod_uid# infox# is_exception apStack = do
tid <- myThreadId
let resume = ResumeContext
{ resumeBreakMVar = breakMVar
@@ -349,8 +352,10 @@ withBreakAction opts breakMVar statusMVar act
then pure Nothing
else do
tick_mod <- peekCString (Ptr tick_mod#)
+ tick_mod_uid <- peekCString (Ptr tick_mod_uid#)
info_mod <- peekCString (Ptr info_mod#)
- pure (Just (EvalBreakpoint tick_mod (I# tickx#) info_mod (I# infox#)))
+ info_mod_uid <- peekCString (Ptr info_mod_uid#)
+ pure (Just (EvalBreakpoint tick_mod tick_mod_uid (I# tickx#) info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
takeMVar breakMVar
@@ -400,8 +405,10 @@ resetStepFlag = poke stepFlag 0
type BreakpointCallback
= Addr# -- pointer to the breakpoint tick module name
+ -> Addr# -- pointer to the breakpoint tick module unit id
-> Int# -- breakpoint tick index
-> Addr# -- pointer to the breakpoint info module name
+ -> Addr# -- pointer to the breakpoint info module unit id
-> Int# -- breakpoint info index
-> Bool -- exception?
-> HValue -- the AP_STACK, or exception
@@ -414,8 +421,8 @@ noBreakStablePtr :: StablePtr BreakpointCallback
noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
noBreakAction :: BreakpointCallback
-noBreakAction _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
-noBreakAction _ _ _ _ True _ = return () -- exception: just continue
+noBreakAction _ _ _ _ _ _ False _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction _ _ _ _ _ _ True _ = return () -- exception: just continue
-- Malloc and copy the bytes. We don't have any way to monitor the
-- lifetime of this memory, so it just leaks.
@@ -453,6 +460,10 @@ newModuleName :: String -> IO (RemotePtr BreakModule)
newModuleName name =
castRemotePtr . toRemotePtr <$> newCString name
+newUnitId :: String -> IO (RemotePtr BreakUnitId)
+newUnitId name =
+ castRemotePtr . toRemotePtr <$> newCString name
+
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
case getApStackVal# apStack stackDepth of
=====================================
rts/Exception.cmm
=====================================
@@ -535,12 +535,16 @@ retry_pop_stack:
// be per-thread.
CInt[rts_stop_on_exception] = 0;
("ptr" ioAction) = ccall deRefStablePtr (W_[rts_breakpoint_io_action] "ptr");
- Sp = Sp - WDS(13);
- Sp(12) = exception;
- Sp(11) = stg_raise_ret_info;
- Sp(10) = exception;
- Sp(9) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
- Sp(8) = stg_ap_ppv_info;
+ Sp = Sp - WDS(17);
+ Sp(16) = exception;
+ Sp(15) = stg_raise_ret_info;
+ Sp(14) = exception;
+ Sp(13) = ghczminternal_GHCziInternalziTypes_True_closure; // True <=> an exception
+ Sp(12) = stg_ap_ppv_info;
+ Sp(11) = 0;
+ Sp(10) = stg_ap_n_info;
+ Sp(9) = 0;
+ Sp(8) = stg_ap_n_info;
Sp(7) = 0;
Sp(6) = stg_ap_n_info;
Sp(5) = 0;
=====================================
rts/Interpreter.c
=====================================
@@ -1245,9 +1245,9 @@ run_BCO:
/* check for a breakpoint on the beginning of a let binding */
case bci_BRK_FUN:
{
- int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_index, arg5_info_index;
+ int arg1_brk_array, arg2_tick_mod, arg3_info_mod, arg4_tick_mod_id, arg5_info_mod_id, arg6_tick_index, arg7_info_index;
#if defined(PROFILING)
- int arg6_cc;
+ int arg8_cc;
#endif
StgArrBytes *breakPoints;
int returning_from_break;
@@ -1264,10 +1264,12 @@ run_BCO:
arg1_brk_array = BCO_GET_LARGE_ARG;
arg2_tick_mod = BCO_GET_LARGE_ARG;
arg3_info_mod = BCO_GET_LARGE_ARG;
- arg4_tick_index = BCO_NEXT;
- arg5_info_index = BCO_NEXT;
+ arg4_tick_mod_id = BCO_GET_LARGE_ARG;
+ arg5_info_mod_id = BCO_GET_LARGE_ARG;
+ arg6_tick_index = BCO_NEXT;
+ arg7_info_index = BCO_NEXT;
#if defined(PROFILING)
- arg6_cc = BCO_GET_LARGE_ARG;
+ arg8_cc = BCO_GET_LARGE_ARG;
#else
BCO_GET_LARGE_ARG;
#endif
@@ -1280,7 +1282,7 @@ run_BCO:
#if defined(PROFILING)
cap->r.rCCCS = pushCostCentre(cap->r.rCCCS,
- (CostCentre*)BCO_LIT(arg6_cc));
+ (CostCentre*)BCO_LIT(arg8_cc));
#endif
// if we are returning from a break then skip this section
@@ -1292,11 +1294,11 @@ run_BCO:
// stop the current thread if either the
// "rts_stop_next_breakpoint" flag is true OR if the
// ignore count for this particular breakpoint is zero
- StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg4_tick_index];
+ StgInt ignore_count = ((StgInt*)breakPoints->payload)[arg6_tick_index];
if (rts_stop_next_breakpoint == false && ignore_count > 0)
{
// decrement and write back ignore count
- ((StgInt*)breakPoints->payload)[arg4_tick_index] = --ignore_count;
+ ((StgInt*)breakPoints->payload)[arg6_tick_index] = --ignore_count;
}
else if (rts_stop_next_breakpoint == true || ignore_count == 0)
{
@@ -1330,8 +1332,10 @@ run_BCO:
// continue execution of this BCO when the IO action returns.
//
// ioAction :: Addr# -- the breakpoint tick module
+ // -> Addr# -- the breakpoint tick module unit id
// -> Int# -- the breakpoint tick index
// -> Addr# -- the breakpoint info module
+ // -> Addr# -- the breakpoint info module unit id
// -> Int# -- the breakpoint info index
// -> Bool -- exception?
// -> HValue -- the AP_STACK, or exception
@@ -1340,17 +1344,21 @@ run_BCO:
ioAction = (StgClosure *) deRefStablePtr (
rts_breakpoint_io_action);
- Sp_subW(15);
- SpW(14) = (W_)obj;
- SpW(13) = (W_)&stg_apply_interp_info;
- SpW(12) = (W_)new_aps;
- SpW(11) = (W_)False_closure; // True <=> an exception
- SpW(10) = (W_)&stg_ap_ppv_info;
- SpW(9) = (W_)arg5_info_index;
+ Sp_subW(19);
+ SpW(18) = (W_)obj;
+ SpW(17) = (W_)&stg_apply_interp_info;
+ SpW(16) = (W_)new_aps;
+ SpW(15) = (W_)False_closure; // True <=> an exception
+ SpW(14) = (W_)&stg_ap_ppv_info;
+ SpW(13) = (W_)arg7_info_index;
+ SpW(12) = (W_)&stg_ap_n_info;
+ SpW(11) = (W_)BCO_LIT(arg5_info_mod_id);
+ SpW(10) = (W_)&stg_ap_n_info;
+ SpW(9) = (W_)BCO_LIT(arg3_info_mod);
SpW(8) = (W_)&stg_ap_n_info;
- SpW(7) = (W_)BCO_LIT(arg3_info_mod);
+ SpW(7) = (W_)arg6_tick_index;
SpW(6) = (W_)&stg_ap_n_info;
- SpW(5) = (W_)arg4_tick_index;
+ SpW(5) = (W_)BCO_LIT(arg4_tick_mod_id);
SpW(4) = (W_)&stg_ap_n_info;
SpW(3) = (W_)BCO_LIT(arg2_tick_mod);
SpW(2) = (W_)&stg_ap_n_info;
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f071532b8f1b11ef4a09989f879d8fb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f071532b8f1b11ef4a09989f879d8fb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units] 3 commits: ghci: Use loadInterfaceForModule rather than loadSrcInterface in mkTopLevEnv
by Hannes Siebenhandl (＠fendor) 17 Apr '25
by Hannes Siebenhandl (＠fendor) 17 Apr '25
17 Apr '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC
Commits:
259ab6b7 by Matthew Pickering at 2025-04-17T13:30:37+02:00
ghci: Use loadInterfaceForModule rather than loadSrcInterface in mkTopLevEnv
loadSrcInterface takes a user given `ModuleName` and resolves it to the
module which needs to be loaded (taking into account module
renaming/visibility etc).
loadInterfaceForModule takes a specific module and loads it.
The modules in `ImpDeclSpec` have already been resolved to the actual
module to get the information from during renaming. Therefore we just
need to fetch the precise interface from disk (and not attempt to rename
it again).
Fixes #25951
- - - - -
368a358b by fendor at 2025-04-17T13:30:37+02:00
Make GHCi commands compatible with multiple home units
FIXME: proper commit message
- - - - -
f56a7898 by fendor at 2025-04-17T13:30:37+02:00
Add testcases for GHCi multiple home units
Adds the following testcases:
* Evaluate code with a single home unit using 'initMulti' initialisation
logic
* More complicated testcase with multiple home units, testing reload
logic and code evaluation.
- - - - -
35 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Types.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
- testsuite/driver/testlib.py
- + testsuite/tests/ghci/prog-mhu001/Makefile
- + testsuite/tests/ghci/prog-mhu001/e/E.hs
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001.T
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001.script
- + testsuite/tests/ghci/prog-mhu001/prog-mhu001.stdout
- + testsuite/tests/ghci/prog-mhu001/unitE
- + testsuite/tests/ghci/prog-mhu002/Makefile
- + testsuite/tests/ghci/prog-mhu002/a/A.hs
- + testsuite/tests/ghci/prog-mhu002/b/B.hs
- + testsuite/tests/ghci/prog-mhu002/c/C.hs
- + testsuite/tests/ghci/prog-mhu002/d/Main.hs
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002.T
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002.script
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002.stderr
- + testsuite/tests/ghci/prog-mhu002/prog-mhu002.stdout
- + testsuite/tests/ghci/prog-mhu002/unitA
- + testsuite/tests/ghci/prog-mhu002/unitB
- + testsuite/tests/ghci/prog-mhu002/unitC
- + testsuite/tests/ghci/prog-mhu002/unitD
- + testsuite/tests/ghci/scripts/GhciPackageRename.hs
- + testsuite/tests/ghci/scripts/GhciPackageRename.script
- + testsuite/tests/ghci/scripts/GhciPackageRename.stdout
- testsuite/tests/ghci/scripts/all.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3e0b1649b2ca60207aa57e144af655…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3e0b1649b2ca60207aa57e144af655…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/interpreter_primops] Fix some macros.
by Andreas Klebinger (＠AndreasK) 17 Apr '25
by Andreas Klebinger (＠AndreasK) 17 Apr '25
17 Apr '25
Andreas Klebinger pushed to branch wip/andreask/interpreter_primops at Glasgow Haskell Compiler / GHC
Commits:
69ac44b9 by Andreas Klebinger at 2025-04-17T13:26:53+02:00
Fix some macros.
- - - - -
1 changed file:
- rts/Interpreter.c
Changes:
=====================================
rts/Interpreter.c
=====================================
@@ -199,11 +199,11 @@ See also Note [Width of parameters] for some more motivation.
(RTS_LIKELY(((StgWord*) Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame))))
-#define WDS_TO_W64(n) (n * sizeof(StgWord64) / sizeof(StgWord))
+#define W64S_TO_WDS(n) ((n) * sizeof(StgWord64) / sizeof(StgWord))
// Always safe to use - Return the value at the address
#define ReadSpW(n) (*((StgWord*) SafeSpWP(n)))
-#define ReadSpW64(n) (*((StgWord64*) SafeSpWP(WDS_TO_W64(n))))
+#define ReadSpW64(n) (*((StgWord64*) SafeSpWP(W64S_TO_WDS(n))))
// Perhaps confusingly this still reads a full word, merely the offset is in bytes.
#define ReadSpB(n) (*((StgWord*) SafeSpBP(n)))
@@ -249,9 +249,9 @@ See ticket #25750
#define SafeSpWP(n) \
((StgWord*) ((WITHIN_CAP_CHUNK_BOUNDS_W(n)) ? Sp_plusW(n) : slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n)))
#define SafeSpBP(off_w) \
- ( (StgWord*) (WITHIN_CAP_CHUNK_BOUNDS_W((1+(off_w))/sizeof(StgWord))) ? \
+ ( (StgWord*) ((WITHIN_CAP_CHUNK_BOUNDS_W((1+(off_w))/sizeof(StgWord))) ? \
Sp_plusB(off_w) : \
- (StgWord*) ((ptrdiff_t)((off_w) % sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, (off_w)/sizeof(StgWord))))
+ (StgWord*) ((ptrdiff_t)((off_w) % sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, (off_w)/sizeof(StgWord)))))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69ac44b9961e33059b8932b9775c24d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69ac44b9961e33059b8932b9775c24d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] template-haskell: Remove `addrToByteArrayName` and `addrToByteArray`
by Marge Bot (＠marge-bot) 17 Apr '25
by Marge Bot (＠marge-bot) 17 Apr '25
17 Apr '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
386f1854 by Teo Camarasu at 2025-04-17T04:31:55-04:00
template-haskell: Remove `addrToByteArrayName` and `addrToByteArray`
These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage.
Resolves #24782
- - - - -
3 changed files:
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- testsuite/tests/interface-stability/template-haskell-exports.stdout
Changes:
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -1,6 +1,6 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
-{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE Safe #-}
{-# LANGUAGE UnboxedTuples #-}
module Language.Haskell.TH.Syntax (
@@ -190,16 +190,11 @@ module Language.Haskell.TH.Syntax (
nothingName,
rightName,
trueName,
- addrToByteArrayName,
- addrToByteArray,
)
where
-import Data.Array.Byte
import GHC.Boot.TH.Lift
import GHC.Boot.TH.Syntax
-import GHC.Exts
-import GHC.ST
import System.FilePath
-- This module completely re-exports 'GHC.Boot.TH.Syntax',
@@ -211,17 +206,3 @@ makeRelativeToProject fp | isRelative fp = do
root <- getPackageRoot
return (root </> fp)
makeRelativeToProject fp = return fp
-
--- The following two defintions are copied from 'Data.Byte.Array'
--- in order to preserve the old export list of 'TH.Syntax'.
--- They will soon be removed as part of #24782.
-
-addrToByteArrayName :: Name
-addrToByteArrayName = 'addrToByteArray
-
-addrToByteArray :: Int -> Addr# -> ByteArray
-addrToByteArray (I# len) addr = runST $ ST $
- \s -> case newByteArray# len s of
- (# s', mb #) -> case copyAddrToByteArray# addr mb 0# len s' of
- s'' -> case unsafeFreezeByteArray# mb s'' of
- (# s''', ret #) -> (# s''', ByteArray ret #)
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -13,6 +13,8 @@
* Remove the `Language.Haskell.TH.Lib.Internal` module. This module has long been deprecated, and exposes compiler internals.
Users should use `Language.Haskell.TH.Lib` instead, which exposes a stable version of this API.
+
+ * Remove `addrToByteArrayName` and `addrToByteArray` from `Language.Haskell.TH.Syntax`. These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage.
## 2.23.0.0
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
@@ -1369,7 +1369,7 @@ module Language.Haskell.TH.Quote where
quoteFile :: QuasiQuoter -> QuasiQuoter
module Language.Haskell.TH.Syntax where
- -- Safety: Trustworthy
+ -- Safety: Safe
type AnnLookup :: *
data AnnLookup = AnnLookupModule Module | AnnLookupName Name
type AnnTarget :: *
@@ -1780,8 +1780,6 @@ module Language.Haskell.TH.Syntax where
addModFinalizer :: Q () -> Q ()
addTempFile :: GHC.Internal.Base.String -> Q GHC.Internal.IO.FilePath
addTopDecls :: [Dec] -> Q ()
- addrToByteArray :: GHC.Internal.Types.Int -> GHC.Internal.Prim.Addr# -> Data.Array.Byte.ByteArray
- addrToByteArrayName :: Name
badIO :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a
bindCode :: forall (m :: * -> *) a (r :: GHC.Internal.Types.RuntimeRep) (b :: TYPE r). GHC.Internal.Base.Monad m => m a -> (a -> Code m b) -> Code m b
bindCode_ :: forall (m :: * -> *) a (r :: GHC.Internal.Types.RuntimeRep) (b :: TYPE r). GHC.Internal.Base.Monad m => m a -> Code m b -> Code m b
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/386f18548e3c66d04f648a9d34f167a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/386f18548e3c66d04f648a9d34f167a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0