07 Jul '25
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
2fb3b1ba by Apoorv Ingle at 2025-07-07T00:16:14-05:00
- kill tcl_in_gen_code
- It is subsumed by `ErrCtxtStack` which keep tracks of `ErrCtxt` and code ctxt
- - - - -
5 changed files:
- compiler/GHC/Hs.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
Changes:
=====================================
compiler/GHC/Hs.hs
=====================================
@@ -38,8 +38,6 @@ module GHC.Hs (
HsModule(..), AnnsModule(..),
HsParsedModule(..), XModulePs(..),
- SrcCodeCtxt(..), isUserCodeCtxt, isGeneratedCodeCtxt
-
) where
-- friends:
@@ -149,17 +147,3 @@ data HsParsedModule = HsParsedModule {
-- the .hi file, so that we can force recompilation if any of
-- them change (#3589)
}
-
--- Used in TcLclCtxt.tcl_in_gen_code to mark if the current expression
--- is a user generated code or a compiler generated expansion of some user written code
-data SrcCodeCtxt
- = UserCode
- | GeneratedCode SrcCodeOrigin
-
-isUserCodeCtxt :: SrcCodeCtxt -> Bool
-isUserCodeCtxt UserCode = True
-isUserCodeCtxt _ = False
-
-isGeneratedCodeCtxt :: SrcCodeCtxt -> Bool
-isGeneratedCodeCtxt UserCode = False
-isGeneratedCodeCtxt _ = True
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -189,8 +189,8 @@ tcExprSigma inst rn_expr
= do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr
; do_ql <- wantQuickLook rn_fun
; (tc_fun, fun_sigma) <- tcInferAppHead fun
- ; code_ctxt <- getSrcCodeCtxt
- ; let fun_orig = srcCodeCtxtCtOrigin rn_expr code_ctxt
+ ; code_orig <- getSrcCodeOrigin
+ ; let fun_orig = srcCodeOriginCtOrigin rn_expr code_orig
; (inst_args, app_res_sigma) <- tcInstFun do_ql inst fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args
; tc_args <- tcValArgs do_ql rn_fun inst_args
; let tc_expr = rebuildHsApps (tc_fun, fun_ctxt) tc_args
@@ -417,8 +417,8 @@ tcApp rn_expr exp_res_ty
; let tc_head = (tc_fun, fun_loc)
-- Step 3: Instantiate the function type (taking a quick look at args)
; do_ql <- wantQuickLook rn_fun
- ; code_ctxt <- getSrcCodeCtxt
- ; let fun_orig = srcCodeCtxtCtOrigin rn_fun code_ctxt
+ ; code_orig <- getSrcCodeOrigin
+ ; let fun_orig = srcCodeOriginCtOrigin rn_fun code_orig
; traceTc "tcApp:inferAppHead" $
vcat [ text "tc_fun:" <+> ppr tc_fun
, text "fun_sigma:" <+> ppr fun_sigma
@@ -857,8 +857,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args
-- Rule IARG from Fig 4 of the QL paper:
go1 pos acc fun_ty
(EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args)
- = do { let herald | DoStmtOrigin <- fun_orig = ExpectedFunTySyntaxOp fun_orig tc_fun -- cf. RepPolyDoBind.hs
- | otherwise = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
+ = do { let herald = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
; (wrap, arg_ty, res_ty) <-
-- NB: matchActualFunTy does the rep-poly check.
-- For example, suppose we have f :: forall r (a::TYPE r). a -> Int
=====================================
compiler/GHC/Tc/Types/LclEnv.hs
=====================================
@@ -21,13 +21,14 @@ module GHC.Tc.Types.LclEnv (
, setLclEnvTypeEnv
, modifyLclEnvTcLevel
- , getLclEnvSrcCodeCtxt
- , setLclEnvSrcCodeCtxt
- , setLclCtxtSrcCodeCtxt
+ , getLclEnvSrcCodeOrigin
+ , setLclEnvSrcCodeOrigin
+ , setLclCtxtSrcCodeOrigin
, lclEnvInGeneratedCode
, addLclEnvErrCtxt
+ , ErrCtxtStack (..)
, ArrowCtxt(..)
, ThBindEnv
, TcTypeEnv
@@ -35,7 +36,7 @@ module GHC.Tc.Types.LclEnv (
import GHC.Prelude
-import GHC.Hs ( SrcCodeCtxt (..), isGeneratedCodeCtxt )
+import GHC.Hs ( SrcCodeOrigin )
import GHC.Tc.Utils.TcType ( TcLevel )
import GHC.Tc.Errors.Types ( TcRnMessage )
@@ -90,11 +91,29 @@ data TcLclEnv -- Changes as we move inside an expression
tcl_errs :: TcRef (Messages TcRnMessage) -- Place to accumulate diagnostics
}
+
+data ErrCtxtStack
+ = UserCodeCtxt {err_ctxt :: [ErrCtxt]}
+ | GeneratedCodeCtxt { src_code_origin :: SrcCodeOrigin
+ , err_ctxt :: [ErrCtxt] }
+
+isGeneratedCodeCtxt :: ErrCtxtStack -> Bool
+isGeneratedCodeCtxt UserCodeCtxt{} = False
+isGeneratedCodeCtxt _ = True
+
+get_src_code_origin :: ErrCtxtStack -> Maybe SrcCodeOrigin
+get_src_code_origin (UserCodeCtxt{}) = Nothing
+get_src_code_origin es = Just $ src_code_origin es
+
+modify_err_ctxt_stack :: ([ErrCtxt] -> [ErrCtxt]) -> ErrCtxtStack -> ErrCtxtStack
+modify_err_ctxt_stack f (UserCodeCtxt e) = UserCodeCtxt (f e)
+modify_err_ctxt_stack _ c = c -- any updates on the err context in generated context should be ignored
+
+
data TcLclCtxt
= TcLclCtxt {
tcl_loc :: RealSrcSpan, -- Source span
- tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top
- tcl_in_gen_code :: SrcCodeCtxt,
+ tcl_ctxt :: ErrCtxtStack,
tcl_tclvl :: TcLevel,
tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings,
-- and for tidying type
@@ -159,28 +178,28 @@ getLclEnvLoc :: TcLclEnv -> RealSrcSpan
getLclEnvLoc = tcl_loc . tcl_lcl_ctxt
getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt]
-getLclEnvErrCtxt = tcl_ctxt . tcl_lcl_ctxt
+getLclEnvErrCtxt = err_ctxt . tcl_ctxt . tcl_lcl_ctxt
setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv
-setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt })
+setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ _ -> ctxt) (tcl_ctxt env) })
addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
-addLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt : (tcl_ctxt env) })
+addLclEnvErrCtxt ec = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ctxt -> ec : ctxt) (tcl_ctxt env) })
-getLclEnvSrcCodeCtxt :: TcLclEnv -> SrcCodeCtxt
-getLclEnvSrcCodeCtxt = tcl_in_gen_code . tcl_lcl_ctxt
+getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin
+getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_ctxt . tcl_lcl_ctxt
-lclEnvInGeneratedCode :: TcLclEnv -> Bool
-lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt
+setLclEnvSrcCodeOrigin :: SrcCodeOrigin -> TcLclEnv -> TcLclEnv
+setLclEnvSrcCodeOrigin o = modifyLclCtxt (setLclCtxtSrcCodeOrigin o)
-lclCtxtInGeneratedCode :: TcLclCtxt -> Bool
-lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_in_gen_code
+setLclCtxtSrcCodeOrigin :: SrcCodeOrigin -> TcLclCtxt -> TcLclCtxt
+setLclCtxtSrcCodeOrigin o ctxt = ctxt { tcl_ctxt = GeneratedCodeCtxt o (err_ctxt $ tcl_ctxt ctxt) }
-setLclCtxtSrcCodeCtxt :: SrcCodeCtxt -> TcLclCtxt -> TcLclCtxt
-setLclCtxtSrcCodeCtxt userOrGen env = env { tcl_in_gen_code = userOrGen }
+lclCtxtInGeneratedCode :: TcLclCtxt -> Bool
+lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_ctxt
-setLclEnvSrcCodeCtxt :: SrcCodeCtxt -> TcLclEnv -> TcLclEnv
-setLclEnvSrcCodeCtxt userOrGen = modifyLclCtxt (\ctxt -> setLclCtxtSrcCodeCtxt userOrGen ctxt)
+lclEnvInGeneratedCode :: TcLclEnv -> Bool
+lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt
getLclEnvBinderStack :: TcLclEnv -> TcBinderStack
getLclEnvBinderStack = tcl_bndrs . tcl_lcl_ctxt
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -19,7 +19,7 @@ module GHC.Tc.Types.Origin (
-- * CtOrigin
CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
- srcCodeCtxtCtOrigin,
+ srcCodeOriginCtOrigin,
isVisibleOrigin, toInvisibleOrigin,
pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin,
isWantedSuperclassOrigin,
@@ -653,6 +653,7 @@ data CtOrigin
Type -- the instantiated type of the method
| AmbiguityCheckOrigin UserTypeCtxt
| ImplicitLiftOrigin HsImplicitLiftSplice
+ | ExpansionOrigin SrcCodeOrigin -- This is due to an expansion of the original thing given by SrcCodeOrigin
data NonLinearPatternReason
= LazyPatternReason
@@ -764,18 +765,13 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression"
exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms]
exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms]
exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms]
-exprCtOrigin (XExpr (ExpandedThingRn o _)) = srcCodeOriginCtOrigin o
+exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o
exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e
exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f)
-srcCodeOriginCtOrigin :: SrcCodeOrigin -> CtOrigin
-srcCodeOriginCtOrigin (OrigExpr e) = exprCtOrigin e
-srcCodeOriginCtOrigin (OrigStmt{}) = DoStmtOrigin
-srcCodeOriginCtOrigin (OrigPat p) = DoPatOrigin p
-
-srcCodeCtxtCtOrigin :: HsExpr GhcRn -> SrcCodeCtxt -> CtOrigin
-srcCodeCtxtCtOrigin e UserCode = exprCtOrigin e
-srcCodeCtxtCtOrigin _ (GeneratedCode e) = srcCodeOriginCtOrigin e
+srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe SrcCodeOrigin -> CtOrigin
+srcCodeOriginCtOrigin e Nothing = exprCtOrigin e
+srcCodeOriginCtOrigin _ (Just e) = ExpansionOrigin e
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
@@ -801,6 +797,14 @@ pprCtOrigin :: CtOrigin -> SDoc
pprCtOrigin (GivenOrigin sk)
= ctoHerald <+> ppr sk
+pprCtOrigin (ExpansionOrigin o)
+ = ctoHerald <+> what
+ where what :: SDoc
+ what = case o of
+ OrigStmt{} -> text "a do statement"
+ OrigExpr e -> text "an expression" <+> ppr e
+ OrigPat p -> text "a pattern" <+> ppr p
+
pprCtOrigin (GivenSCOrigin sk d blk)
= vcat [ ctoHerald <+> pprSkolInfo sk
, whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ]
@@ -984,6 +988,10 @@ pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance"
pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check"
pprCtO (ImpedanceMatching {}) = text "combining required constraints"
pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)]
+pprCtO (ExpansionOrigin (OrigPat p)) = hsep [text "a pattern" <+> quotes (ppr p)]
+pprCtO (ExpansionOrigin (OrigStmt{})) = text "a do statement"
+pprCtO (ExpansionOrigin (OrigExpr{})) = text "an expression"
+
pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc
pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear")
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -58,7 +58,7 @@ module GHC.Tc.Utils.Monad(
addDependentFiles,
-- * Error management
- getSrcCodeCtxt,
+ getSrcCodeOrigin,
getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM,
inGeneratedCode, setInGeneratedCode,
wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
@@ -400,8 +400,7 @@ initTcWithGbl hsc_env gbl_env loc do_this
tcl_lcl_ctxt = TcLclCtxt {
tcl_loc = loc,
-- tcl_loc should be over-ridden very soon!
- tcl_in_gen_code = UserCode,
- tcl_ctxt = [],
+ tcl_ctxt = UserCodeCtxt [],
tcl_rdr = emptyLocalRdrEnv,
tcl_th_ctxt = topLevel,
tcl_th_bndrs = emptyNameEnv,
@@ -978,21 +977,21 @@ setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-- See Note [Error contexts in generated code]
-- for the tcl_in_gen_code manipulation
setSrcSpan (RealSrcSpan loc _) thing_inside
- = updLclCtxt (\env -> env { tcl_loc = loc, tcl_in_gen_code = UserCode })
+ = updLclCtxt (\env -> env { tcl_loc = loc, tcl_ctxt = UserCodeCtxt (err_ctxt $ tcl_ctxt env)})
thing_inside
setSrcSpan (UnhelpfulSpan _) thing_inside
= thing_inside
-getSrcCodeCtxt :: TcRn SrcCodeCtxt
-getSrcCodeCtxt = getLclEnvSrcCodeCtxt <$> getLclEnv
+getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin)
+getSrcCodeOrigin = getLclEnvSrcCodeOrigin <$> getLclEnv
-- | Mark the inner computation as being done inside generated code.
--
-- See Note [Error contexts in generated code]
setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a
-setInGeneratedCode scOrig thing_inside =
- updLclCtxt (setLclCtxtSrcCodeCtxt (GeneratedCode scOrig)) thing_inside
+setInGeneratedCode sco thing_inside =
+ updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside
setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA l = setSrcSpan (locA l)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fb3b1ba81aa2bd6d2b2985139638db…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fb3b1ba81aa2bd6d2b2985139638db…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/spec_tyfams] Accept change to T23398
by Simon Peyton Jones (＠simonpj) 07 Jul '25
by Simon Peyton Jones (＠simonpj) 07 Jul '25
07 Jul '25
Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC
Commits:
d95dd951 by Simon Peyton Jones at 2025-07-06T23:17:26+01:00
Accept change to T23398
- - - - -
2 changed files:
- testsuite/tests/dmdanal/should_compile/T23398.hs
- testsuite/tests/dmdanal/should_compile/T23398.stderr
Changes:
=====================================
testsuite/tests/dmdanal/should_compile/T23398.hs
=====================================
@@ -6,10 +6,11 @@ type PairDict a = (Eq a, Show a)
foo :: PairDict a => a -> a -> String
foo x y | x==y = show x
| otherwise = show y
-
--- In worker/wrapper we'd like to unbox the pair
--- but not (Eq a) and (Show a)
+-- In worker/wrapper we don't want to unbox PairDict
+-- See (DNB1) Note [Do not unbox class dictionaries] in GHC.Core.Opt.DmdAnal
bar :: (a ~ b, Show a) => Int -> a -> (b, String)
bar 0 x = (x, show x)
bar n x = bar (n-1) x
+-- ...but we do want to unbox the (a~b)
+-- see (DNB2) in the same Note
=====================================
testsuite/tests/dmdanal/should_compile/T23398.stderr
=====================================
@@ -1,42 +1,35 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 76, types: 117, coercions: 4, joins: 0/0}
+ = {terms: 65, types: 107, coercions: 4, joins: 0/0}
--- RHS size: {terms: 18, types: 11, coercions: 0, joins: 0/0}
-T23398.$wfoo [InlPrag=[2]]
- :: forall a. (Eq a, Show a) => a -> a -> String
-[GblId[StrictWorker([!, !])],
- Arity=4,
- Str=<SP(1C(1,C(1,L)),A)><SP(A,1C(1,L),A)><L><L>,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [30 60 0 0] 120 0}]
-T23398.$wfoo
- = \ (@a) (ww :: Eq a) (ww1 :: Show a) (eta :: a) (eta1 :: a) ->
- case == @a ww eta eta1 of {
- False -> show @a ww1 eta1;
- True -> show @a ww1 eta
- }
-
--- RHS size: {terms: 12, types: 12, coercions: 0, joins: 0/0}
-foo [InlPrag=[2]] :: forall a. PairDict a => a -> a -> String
+-- RHS size: {terms: 20, types: 21, coercions: 0, joins: 0/0}
+foo :: forall a. PairDict a => a -> a -> String
[GblId,
Arity=3,
- Str=<S!P(SP(SC(S,C(1,L)),A),SP(A,SC(S,L),A))><L><L>,
- Unf=Unf{Src=StableSystem, TopLvl=True,
+ Str=<SP(SP(1C(1,C(1,L)),A),SP(A,1C(1,L),A))><L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
- Tmpl= \ (@a)
- ($dCTuple2 [Occ=Once1!] :: PairDict a)
- (eta [Occ=Once1] :: a)
- (eta1 [Occ=Once1] :: a) ->
- case $dCTuple2 of { (ww [Occ=Once1], ww1 [Occ=Once1]) ->
- T23398.$wfoo @a ww ww1 eta eta1
- }}]
+ Guidance=IF_ARGS [90 0 0] 180 0}]
foo
= \ (@a) ($dCTuple2 :: PairDict a) (eta :: a) (eta1 :: a) ->
- case $dCTuple2 of { (ww, ww1) -> T23398.$wfoo @a ww ww1 eta eta1 }
+ case ==
+ @a
+ (GHC.Internal.Classes.$p0CTuple2 @(Eq a) @(Show a) $dCTuple2)
+ eta
+ eta1
+ of {
+ False ->
+ show
+ @a
+ (GHC.Internal.Classes.$p1CTuple2 @(Eq a) @(Show a) $dCTuple2)
+ eta1;
+ True ->
+ show
+ @a
+ (GHC.Internal.Classes.$p1CTuple2 @(Eq a) @(Show a) $dCTuple2)
+ eta
+ }
Rec {
-- RHS size: {terms: 21, types: 19, coercions: 3, joins: 0/0}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d95dd9514120408be196786e91d6b4f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d95dd9514120408be196786e91d6b4f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T23162-spj] We need wanted/wanted fundeps too
by Simon Peyton Jones (＠simonpj) 07 Jul '25
by Simon Peyton Jones (＠simonpj) 07 Jul '25
07 Jul '25
Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC
Commits:
5eea3311 by Simon Peyton Jones at 2025-07-06T23:09:47+01:00
We need wanted/wanted fundeps too
...and some other refactors
- - - - -
4 changed files:
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -413,7 +413,7 @@ solveEqualityDict ev cls tys
do { let loc = ctEvLoc ev
sc_pred = classMethodInstTy sel_id tys
ev_expr = EvExpr $ Var sel_id `mkTyApps` tys `App` evId ev_id
- ; given_ev <- newGivenEvVar loc (sc_pred, ev_expr)
+ ; given_ev <- newGivenEv loc (sc_pred, ev_expr)
; startAgainWith (mkNonCanonical $ CtGiven given_ev) }
| otherwise
= pprPanic "solveEqualityDict" (ppr cls)
@@ -1403,8 +1403,8 @@ now!).
Note [FunDep and implicit parameter reactions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Currently, our story of interacting two dictionaries (or a dictionary
-and top-level instances) for functional dependencies, and implicit
-parameters, is that we simply produce new Wanted equalities. So for example
+and top-level instances) for functional dependencies (including implicit
+parameters), is that we simply produce new Wanted equalities. So for example
class D a b | a -> b where ...
Inert:
@@ -1663,43 +1663,46 @@ doTopFunDepImprovement cts
inst_pred inst_loc
doLocalFunDepImprovement :: Bag DictCt -> TcS (Cts,Bool)
--- Add wanted constraints from type-class functional dependencies
--- against Givens
-doLocalFunDepImprovement cts
+-- Using functional dependencies, interact the unsolved Wanteds
+-- against each other and the inert Givens, to produce new equalities
+doLocalFunDepImprovement wanted
= do { inerts <- getInertCans -- The inert_dicts are all Givens
- ; do_dict_fundeps (do_one (inert_dicts inerts)) cts }
+ ; let all_dicts :: DictMap DictCt -- Both Givens and Wanteds
+ all_dicts = foldr addDict (inert_dicts inerts) wanted
+ ; do_dict_fundeps (do_one all_dicts) wanted }
where
- do_one givens (DictCt { di_cls = cls, di_ev = wanted_ev })
- = do_dict_fundeps do_one_given (findDictsByClass givens cls)
+ -- all_dicts are all the Givens and all the Wanteds
+ do_one all_dicts (DictCt { di_cls = cls, di_ev = wanted_ev })
+ = do_dict_fundeps do_interaction (findDictsByClass all_dicts cls)
where
wanted_pred = ctEvPred wanted_ev
wanted_loc = ctEvLoc wanted_ev
- do_one_given :: DictCt -> TcS (Cts,Bool)
- do_one_given (DictCt { di_ev = given_ev })
+ do_interaction :: DictCt -> TcS (Cts,Bool)
+ do_interaction (DictCt { di_ev = all_ev }) -- This can be Given or Wanted
= do { traceTcS "doLocalFunDepImprovement" $
vcat [ ppr wanted_ev
, pprCtLoc wanted_loc, ppr (isGivenLoc wanted_loc)
- , pprCtLoc given_loc, ppr (isGivenLoc given_loc)
+ , pprCtLoc all_loc, ppr (isGivenLoc all_loc)
, pprCtLoc deriv_loc, ppr (isGivenLoc deriv_loc) ]
; unifyFunDepWanteds wanted_ev $
- improveFromAnother (deriv_loc, given_rewriters)
- given_pred wanted_pred }
+ improveFromAnother (deriv_loc, all_rewriters)
+ all_pred wanted_pred }
where
- given_pred = ctEvPred given_ev
- given_loc = ctEvLoc given_ev
- given_rewriters = ctEvRewriters given_ev
+ all_pred = ctEvPred all_ev
+ all_loc = ctEvLoc all_ev
+ all_rewriters = ctEvRewriters all_ev
deriv_loc = wanted_loc { ctl_depth = deriv_depth
, ctl_origin = deriv_origin }
deriv_depth = ctl_depth wanted_loc `maxSubGoalDepth`
- ctl_depth given_loc
+ ctl_depth all_loc
deriv_origin = FunDepOrigin1 wanted_pred
(ctLocOrigin wanted_loc)
(ctLocSpan wanted_loc)
- given_pred
- (ctLocOrigin given_loc)
- (ctLocSpan given_loc)
+ all_pred
+ (ctLocOrigin all_loc)
+ (ctLocSpan all_loc)
do_dict_fundeps :: (DictCt -> TcS (Cts,Bool)) -> Bag DictCt -> TcS (Cts,Bool)
do_dict_fundeps do_dict_fundep cts
@@ -2047,7 +2050,7 @@ mk_strict_superclasses fuel rec_clss ev@(CtGiven (GivenCt { ctev_evar = evar }))
= -- See Note [Equality superclasses in quantified constraints]
return []
| otherwise
- = do { given_ev <- newGivenEvVar sc_loc $
+ = do { given_ev <- newGivenEv sc_loc $
mk_given_desc sel_id sc_pred
; assertFuelPrecondition fuel $
mk_superclasses fuel rec_clss (CtGiven given_ev) tvs theta sc_pred }
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -780,12 +780,12 @@ can_eq_app ev s1 t1 s2 t2
= do { let co = mkCoVarCo evar
co_s = mkLRCo CLeft co
co_t = mkLRCo CRight co
- ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2
- , evCoercion co_s )
- ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
- , evCoercion co_t )
- ; emitWorkNC [CtGiven evar_t]
- ; startAgainWith (mkNonCanonical $ CtGiven evar_s) }
+ ; ev_s <- newGivenEv loc ( mkTcEqPredLikeEv ev s1 s2
+ , evCoercion co_s )
+ ; ev_t <- newGivenEv loc ( mkTcEqPredLikeEv ev t1 t2
+ , evCoercion co_t )
+ ; emitWorkNC [CtGiven ev_t]
+ ; startAgainWith (mkNonCanonical $ CtGiven ev_s) }
where
loc = ctEvLoc ev
@@ -1632,7 +1632,7 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2
-> do { let kind_co = mkKindCo (mkCoVarCo evar)
pred_ty = unSwap swapped mkNomEqPred ki1 ki2
kind_loc = mkKindEqLoc xi1 xi2 loc
- ; kind_ev <- newGivenEvVar kind_loc (pred_ty, evCoercion kind_co)
+ ; kind_ev <- newGivenEv kind_loc (pred_ty, evCoercion kind_co)
; emitWorkNC [CtGiven kind_ev]
; finish emptyRewriterSet (givenCtEvCoercion kind_ev) }
@@ -2597,7 +2597,7 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio
= do { let new_tm = evCoercion ( mkSymCo lhs_co
`mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar)
`mkTransCo` rhs_co)
- ; CtGiven <$> newGivenEvVar loc (new_pred, new_tm) }
+ ; CtGiven <$> newGivenEv loc (new_pred, new_tm) }
| CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rewriters }) <- old_ev
= do { let rewriters' = rewriters S.<> new_rewriters
@@ -3044,6 +3044,7 @@ equality with the template on the left. Delicate, but it works.
-}
--------------------
+
tryFunDeps :: EqCt -> SolverStage ()
tryFunDeps work_item@(EqCt { eq_lhs = lhs, eq_ev = ev, eq_eq_rel = eq_rel })
| NomEq <- eq_rel
@@ -3253,7 +3254,7 @@ improveWantedLocalFunEqs
-> TyCon -> [TcType] -> CtEvidence -> Xi -- Work item (Wanted)
-> TcS Bool -- True <=> some unifications
-- Emit improvement equalities for a Wanted constraint, by comparing
--- the current work item with inert CFunEqs (boh Given and Wanted)
+-- the current work item with inert CFunEqs (both Given and Wanted)
-- E.g. x + y ~ z, x + y' ~ z => [W] y ~ y'
--
-- See Note [FunDep and implicit parameter reactions]
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -57,7 +57,7 @@ module GHC.Tc.Solver.Monad (
unifyTyVar, reportUnifications,
setEvBind, setWantedEq,
setWantedEvTerm, setEvBindIfWanted,
- newEvVar, newGivenEvVar, emitNewGivens,
+ newEvVar, newGivenEv, emitNewGivens,
checkReductionDepth,
getSolvedDicts, setSolvedDicts,
@@ -2081,12 +2081,12 @@ newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds
newEvVar :: TcPredType -> TcS EvVar
newEvVar pred = wrapTcS (TcM.newEvVar pred)
-newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS GivenCtEvidence
+newGivenEv :: CtLoc -> (TcPredType, EvTerm) -> TcS GivenCtEvidence
-- Make a new variable of the given PredType,
-- immediately bind it to the given term
-- and return its CtEvidence
-- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint
-newGivenEvVar loc (pred, rhs)
+newGivenEv loc (pred, rhs)
= do { new_ev <- newBoundEvVarId pred rhs
; return $ GivenCt { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc } }
@@ -2101,7 +2101,7 @@ newBoundEvVarId pred rhs
emitNewGivens :: CtLoc -> [(Role,TcCoercion)] -> TcS ()
emitNewGivens loc pts
= do { traceTcS "emitNewGivens" (ppr pts)
- ; gs <- mapM (newGivenEvVar loc) $
+ ; gs <- mapM (newGivenEv loc) $
[ (mkEqPredRole role ty1 ty2, evCoercion co)
| (role, co) <- pts
, let Pair ty1 ty2 = coercionKind co
@@ -2484,7 +2484,7 @@ checkTypeEq ev eq_rel lhs rhs =
---------------------------
mk_new_given :: (TcTyVar, TcType) -> TcS Ct
mk_new_given (new_tv, fam_app)
- = mkNonCanonical . CtGiven <$> newGivenEvVar cb_loc (given_pred, given_term)
+ = mkNonCanonical . CtGiven <$> newGivenEv cb_loc (given_pred, given_term)
where
new_ty = mkTyVarTy new_tv
given_pred = mkNomEqPred fam_app new_ty
=====================================
compiler/GHC/Tc/Solver/Solve.hs
=====================================
@@ -1563,7 +1563,7 @@ finish_rewrite
new_tm = assert (coercionRole co == ev_rw_role)
mkEvCast (evId old_evar)
(downgradeRole Representational ev_rw_role co)
- ; new_ev <- newGivenEvVar loc (new_pred, new_tm)
+ ; new_ev <- newGivenEv loc (new_pred, new_tm)
; continueWith $ CtGiven new_ev }
finish_rewrite
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5eea331167b1352565067e4680fc2e8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5eea331167b1352565067e4680fc2e8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T22859] Implement user-defined allocation limit handlers
by Teo Camarasu (＠teo) 07 Jul '25
by Teo Camarasu (＠teo) 07 Jul '25
07 Jul '25
Teo Camarasu pushed to branch wip/T22859 at Glasgow Haskell Compiler / GHC
Commits:
fd88237a by Teo Camarasu at 2025-07-06T22:21:06+01:00
Implement user-defined allocation limit handlers
Allocation Limits allow killing a thread if they allocate more than a
user-specified limit.
We extend this feature to allow more versatile behaviour.
- We allow not killing the thread if the limit is exceeded.
- We allow setting a custom handler to be called when the limit is exceeded.
User-specified allocation limit handlers run in a fresh thread and are passed
the ThreadId of the thread that exceeded its limit.
We introduce utility functions for getting and setting the allocation
limits of other threads, so that users can reset the limit of a thread
from a handler. Both of these are somewhat coarse-grained as we are
unaware of the allocations in the current nursery chunk.
We provide several examples of usages in testsuite/tests/rts/T22859.hs
Resolves #22859
- - - - -
28 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/ghc-experimental/ghc-experimental.cabal.in
- + libraries/ghc-experimental/src/System/Mem/Experimental.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/external-symbols.list.in
- rts/include/rts/storage/GC.h
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- + testsuite/tests/rts/T22859.hs
- + testsuite/tests/rts/T22859.stderr
- testsuite/tests/rts/all.T
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -4065,6 +4065,15 @@ primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp
effect = ReadWriteEffect
out_of_line = True
+primop SetOtherThreadAllocationCounter "setOtherThreadAllocationCounter#" GenPrimOp
+ Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
+ { Sets the allocation counter for the another thread to the given value.
+ This doesn't take allocations into the current nursery chunk into account.
+ Therefore it is only accurate if the other thread is not currently running. }
+ with
+ effect = ReadWriteEffect
+ out_of_line = True
+
primtype StackSnapshot#
{ Haskell representation of a @StgStack*@ that was created (cloned)
with a function in "GHC.Stack.CloneStack". Please check the
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1775,6 +1775,7 @@ emitPrimOp cfg primop =
TraceEventBinaryOp -> alwaysExternal
TraceMarkerOp -> alwaysExternal
SetThreadAllocationCounter -> alwaysExternal
+ SetOtherThreadAllocationCounter -> alwaysExternal
KeepAliveOp -> alwaysExternal
where
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1173,6 +1173,7 @@ genPrim prof bound ty op = case op of
WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n
SetThreadAllocationCounter -> unhandledPrimop op
+ SetOtherThreadAllocationCounter -> unhandledPrimop op
------------------------------- Vector -----------------------------------------
-- For now, vectors are unsupported on the JS backend. Simply put, they do not
=====================================
libraries/ghc-experimental/ghc-experimental.cabal.in
=====================================
@@ -38,6 +38,7 @@ library
GHC.RTS.Flags.Experimental
GHC.Stats.Experimental
Prelude.Experimental
+ System.Mem.Experimental
if arch(wasm32)
exposed-modules: GHC.Wasm.Prim
other-extensions:
=====================================
libraries/ghc-experimental/src/System/Mem/Experimental.hs
=====================================
@@ -0,0 +1,10 @@
+module System.Mem.Experimental
+ ( setGlobalAllocationLimitHandler
+ , AllocationLimitKillBehaviour(..)
+ , getAllocationCounterFor
+ , setAllocationCounterFor
+ , enableAllocationLimitFor
+ , disableAllocationLimitFor
+ )
+ where
+import GHC.Internal.AllocationLimitHandler
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -122,6 +122,7 @@ Library
rts == 1.0.*
exposed-modules:
+ GHC.Internal.AllocationLimitHandler
GHC.Internal.ClosureTypes
GHC.Internal.Control.Arrow
GHC.Internal.Control.Category
=====================================
libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
=====================================
@@ -0,0 +1,117 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# OPTIONS_HADDOCK not-home #-}
+module GHC.Internal.AllocationLimitHandler
+ ( runAllocationLimitHandler
+ , setGlobalAllocationLimitHandler
+ , AllocationLimitKillBehaviour(..)
+ , getAllocationCounterFor
+ , setAllocationCounterFor
+ , enableAllocationLimitFor
+ , disableAllocationLimitFor
+ )
+ where
+import GHC.Internal.Base
+import GHC.Internal.Conc.Sync (ThreadId(..))
+import GHC.Internal.Data.IORef (IORef, readIORef, writeIORef, newIORef)
+import GHC.Internal.Foreign.C.Types
+import GHC.Internal.IO (unsafePerformIO)
+import GHC.Internal.Int (Int64(..))
+
+
+{-# NOINLINE allocationLimitHandler #-}
+allocationLimitHandler :: IORef (ThreadId -> IO ())
+allocationLimitHandler = unsafePerformIO (newIORef defaultHandler)
+
+defaultHandler :: ThreadId -> IO ()
+defaultHandler _ = pure ()
+
+foreign import ccall "setAllocLimitKill" setAllocLimitKill :: CBool -> CBool -> IO ()
+
+runAllocationLimitHandler :: ThreadId# -> IO ()
+runAllocationLimitHandler tid = do
+ hook <- getAllocationLimitHandler
+ hook $ ThreadId tid
+
+getAllocationLimitHandler :: IO (ThreadId -> IO ())
+getAllocationLimitHandler = readIORef allocationLimitHandler
+
+data AllocationLimitKillBehaviour =
+ KillOnAllocationLimit
+ -- ^ Throw a @AllocationLimitExceeded@ async exception to the thread when the
+ -- allocation limit is exceeded.
+ | DontKillOnAllocationLimit
+ -- ^ Do not throw an exception when the allocation limit is exceeded.
+
+-- | Define the behaviour for handling allocation limits.
+-- The default behaviour is to throw an @AllocationLimitExceeded@ async exception to the thread.
+-- This can be overriden using @AllocationLimitKillBehaviour@.
+--
+-- We can set a user-specified handler, which can be run in addition to
+-- or in place of the exception.
+-- This allows for instance logging on the allocation limit being exceeded,
+-- or dynamically determining whether to terminate the thread.
+-- The handler is not guaranteed to run before the thread is terminated or restarted.
+--
+-- Note: that if you don't terminate the thread, then the allocation limit gets
+-- removed.
+-- If you wish to keep the allocation limit you will have to reset it using
+-- @setAllocationCounter@ and @enableAllocationLimit@.
+setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> Maybe (ThreadId -> IO ()) -> IO ()
+setGlobalAllocationLimitHandler killBehaviour mHandler = do
+ shouldRunHandler <- case mHandler of
+ Just hook -> do
+ writeIORef allocationLimitHandler hook
+ pure 1
+ Nothing -> do
+ writeIORef allocationLimitHandler defaultHandler
+ pure 0
+ let shouldKill =
+ case killBehaviour of
+ KillOnAllocationLimit -> 1
+ DontKillOnAllocationLimit -> 0
+ setAllocLimitKill shouldKill shouldRunHandler
+
+-- | Retrieves the allocation counter for the another thread.
+foreign import prim "stg_getOtherThreadAllocationCounterzh" getOtherThreadAllocationCounter#
+ :: ThreadId#
+ -> State# RealWorld
+ -> (# State# RealWorld, Int64# #)
+
+-- | Get the allocation counter for a different thread.
+--
+-- Note: this doesn't take the current nursery chunk into account.
+-- If the thread is running then it may underestimate allocations by the size of a nursery thread.
+getAllocationCounterFor :: ThreadId -> IO Int64
+getAllocationCounterFor (ThreadId t#) = IO $ \s ->
+ case getOtherThreadAllocationCounter# t# s of (# s', i# #) -> (# s', I64# i# #)
+
+-- | Set the allocation counter for a different thread.
+-- This can be combined with 'enableAllocationLimitFor' to enable allocation limits for another thread.
+-- You may wish to do this during a user-specified allocation limit handler.
+--
+-- Note: this doesn't take the current nursery chunk into account.
+-- If the thread is running then it may overestimate allocations by the size of a nursery thread,
+-- and trigger the limit sooner than expected.
+setAllocationCounterFor :: Int64 -> ThreadId -> IO ()
+setAllocationCounterFor (I64# i#) (ThreadId t#) = IO $ \s ->
+ case setOtherThreadAllocationCounter# i# t# s of s' -> (# s', () #)
+
+
+-- | Enable allocation limit processing the thread @t@.
+enableAllocationLimitFor :: ThreadId -> IO ()
+enableAllocationLimitFor (ThreadId t) = do
+ rts_enableThreadAllocationLimit t
+
+-- | Disable allocation limit processing the thread @t@.
+disableAllocationLimitFor :: ThreadId -> IO ()
+disableAllocationLimitFor (ThreadId t) = do
+ rts_disableThreadAllocationLimit t
+
+foreign import ccall unsafe "rts_enableThreadAllocationLimit"
+ rts_enableThreadAllocationLimit :: ThreadId# -> IO ()
+
+foreign import ccall unsafe "rts_disableThreadAllocationLimit"
+ rts_disableThreadAllocationLimit :: ThreadId# -> IO ()
=====================================
rts/Prelude.h
=====================================
@@ -67,6 +67,7 @@ PRELUDE_CLOSURE(ghczminternal_GHCziInternalziEventziWindows_processRemoteComplet
PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure);
PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure);
+PRELUDE_CLOSURE(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure);
PRELUDE_INFO(ghczminternal_GHCziInternalziCString_unpackCStringzh_info);
PRELUDE_INFO(ghczminternal_GHCziInternalziTypes_Czh_con_info);
@@ -102,6 +103,7 @@ PRELUDE_INFO(ghczminternal_GHCziInternalziStable_StablePtr_con_info);
#if defined(mingw32_HOST_OS)
#define processRemoteCompletion_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziEventziWindows_processRemoteCompletion_closure)
#endif
+#define runAllocationLimitHandler_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure)
#define flushStdHandles_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure)
#define runMainIO_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure)
=====================================
rts/PrimOps.cmm
=====================================
@@ -2889,6 +2889,11 @@ stg_getThreadAllocationCounterzh ()
return (StgTSO_alloc_limit(CurrentTSO) - TO_I64(offset));
}
+stg_getOtherThreadAllocationCounterzh ( gcptr t )
+{
+ return (StgTSO_alloc_limit(t));
+}
+
stg_setThreadAllocationCounterzh ( I64 counter )
{
// Allocation in the current block will be subtracted by
@@ -2901,6 +2906,12 @@ stg_setThreadAllocationCounterzh ( I64 counter )
return ();
}
+stg_setOtherThreadAllocationCounterzh ( I64 counter, gcptr t )
+{
+ StgTSO_alloc_limit(t) = counter;
+ return ();
+}
+
#define KEEP_ALIVE_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,c) \
w_ info_ptr, \
=====================================
rts/RtsStartup.c
=====================================
@@ -224,6 +224,7 @@ static void initBuiltinGcRoots(void)
* GHC.Core.Make.mkExceptionId.
*/
getStablePtr((StgPtr)absentSumFieldError_closure);
+ getStablePtr((StgPtr)runAllocationLimitHandler_closure);
}
void
=====================================
rts/RtsSymbols.c
=====================================
@@ -748,6 +748,7 @@ extern char **environ;
SymI_HasProto(rts_enableThreadAllocationLimit) \
SymI_HasProto(rts_disableThreadAllocationLimit) \
SymI_HasProto(rts_setMainThread) \
+ SymI_HasProto(setAllocLimitKill) \
SymI_HasProto(setProgArgv) \
SymI_HasProto(startupHaskell) \
SymI_HasProto(shutdownHaskell) \
@@ -916,7 +917,9 @@ extern char **environ;
SymI_HasDataProto(stg_traceMarkerzh) \
SymI_HasDataProto(stg_traceBinaryEventzh) \
SymI_HasDataProto(stg_getThreadAllocationCounterzh) \
+ SymI_HasDataProto(stg_getOtherThreadAllocationCounterzh) \
SymI_HasDataProto(stg_setThreadAllocationCounterzh) \
+ SymI_HasDataProto(stg_setOtherThreadAllocationCounterzh) \
SymI_HasProto(getMonotonicNSec) \
SymI_HasProto(lockFile) \
SymI_HasProto(unlockFile) \
=====================================
rts/Schedule.c
=====================================
@@ -41,6 +41,7 @@
#include "Threads.h"
#include "Timer.h"
#include "ThreadPaused.h"
+#include "ThreadLabels.h"
#include "Messages.h"
#include "StablePtr.h"
#include "StableName.h"
@@ -94,6 +95,10 @@ StgWord recent_activity = ACTIVITY_YES;
*/
StgWord sched_state = SCHED_RUNNING;
+
+bool allocLimitKill = true;
+bool allocLimitRunHook = false;
+
/*
* This mutex protects most of the global scheduler data in
* the THREADED_RTS runtime.
@@ -1125,19 +1130,36 @@ schedulePostRunThread (Capability *cap, StgTSO *t)
}
}
- //
- // If the current thread's allocation limit has run out, send it
- // the AllocationLimitExceeded exception.
+ // Handle the current thread's allocation limit running out,
if (PK_Int64((W_*)&(t->alloc_limit)) < 0 && (t->flags & TSO_ALLOC_LIMIT)) {
- // Use a throwToSelf rather than a throwToSingleThreaded, because
- // it correctly handles the case where the thread is currently
- // inside mask. Also the thread might be blocked (e.g. on an
- // MVar), and throwToSingleThreaded doesn't unblock it
- // correctly in that case.
- throwToSelf(cap, t, allocationLimitExceeded_closure);
- ASSIGN_Int64((W_*)&(t->alloc_limit),
- (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+ if(allocLimitKill) {
+ // Throw the AllocationLimitExceeded exception.
+ // Use a throwToSelf rather than a throwToSingleThreaded, because
+ // it correctly handles the case where the thread is currently
+ // inside mask. Also the thread might be blocked (e.g. on an
+ // MVar), and throwToSingleThreaded doesn't unblock it
+ // correctly in that case.
+ throwToSelf(cap, t, allocationLimitExceeded_closure);
+ ASSIGN_Int64((W_*)&(t->alloc_limit),
+ (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+ } else {
+ // If we aren't killing the thread, we must disable the limit
+ // otherwise we will immediatelly retrigger it.
+ // User defined handlers should re-enable it if wanted.
+ t->flags = t->flags & ~TSO_ALLOC_LIMIT;
+ }
+
+ if(allocLimitRunHook)
+ {
+ // Create a thread to run the allocation limit handler.
+ StgClosure* c = rts_apply(cap, runAllocationLimitHandler_closure, (StgClosure*)t);
+ StgTSO* hookThread = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, c);
+ setThreadLabel(cap, hookThread, "allocation limit handler thread");
+ // Schedule the handler to be run immediatelly.
+ pushOnRunQueue(cap, hookThread);
+ }
+
}
/* some statistics gathering in the parallel case */
@@ -3342,3 +3364,9 @@ resurrectThreads (StgTSO *threads)
}
}
}
+
+void setAllocLimitKill(bool shouldKill, bool shouldHook)
+{
+ allocLimitKill = shouldKill;
+ allocLimitRunHook = shouldHook;
+}
=====================================
rts/external-symbols.list.in
=====================================
@@ -43,6 +43,7 @@ ghczminternal_GHCziInternalziTypes_Izh_con_info
ghczminternal_GHCziInternalziTypes_Fzh_con_info
ghczminternal_GHCziInternalziTypes_Dzh_con_info
ghczminternal_GHCziInternalziTypes_Wzh_con_info
+ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure
ghczminternal_GHCziInternalziPtr_Ptr_con_info
ghczminternal_GHCziInternalziPtr_FunPtr_con_info
ghczminternal_GHCziInternalziInt_I8zh_con_info
=====================================
rts/include/rts/storage/GC.h
=====================================
@@ -209,6 +209,10 @@ void flushExec(W_ len, AdjustorExecutable exec_addr);
// Used by GC checks in external .cmm code:
extern W_ large_alloc_lim;
+// Should triggering an allocation limit kill the thread
+// and should we run a user-defined hook when it is triggered.
+void setAllocLimitKill(bool, bool);
+
/* -----------------------------------------------------------------------------
Performing Garbage Collection
-------------------------------------------------------------------------- */
=====================================
rts/include/rts/storage/TSO.h
=====================================
@@ -157,9 +157,10 @@ typedef struct StgTSO_ {
/*
* The allocation limit for this thread, which is updated as the
* thread allocates. If the value drops below zero, and
- * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the
- * thread, and give the thread a little more space to handle the
- * exception before we raise the exception again.
+ * TSO_ALLOC_LIMIT is set in flags, then a handler is triggerd.
+ * Either we raise an exception in the thread, and give the thread
+ * a little more space to handle the exception before we raise the
+ * exception again; or we run a user defined handler.
*
* This is an integer, because we might update it in a place where
* it isn't convenient to raise the exception, so we want it to
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -604,7 +604,9 @@ RTS_FUN_DECL(stg_traceEventzh);
RTS_FUN_DECL(stg_traceBinaryEventzh);
RTS_FUN_DECL(stg_traceMarkerzh);
RTS_FUN_DECL(stg_getThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_getOtherThreadAllocationCounterzh);
RTS_FUN_DECL(stg_setThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_setOtherThreadAllocationCounterzh);
RTS_FUN_DECL(stg_castWord64ToDoublezh);
RTS_FUN_DECL(stg_castDoubleToWord64zh);
=====================================
testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
=====================================
@@ -13,13 +13,13 @@ Building library 'q' instantiated with
for bkpcabal08-0.1.0.0...
[2 of 4] Compiling B[sig] ( q/B.hsig, nothing )
[3 of 4] Compiling M ( q/M.hs, nothing ) [A changed]
-[4 of 4] Instantiating bkpcabal08-0.1.0.0-CoQJNXLfoYQ4TyvApzFHv-p
+[4 of 4] Instantiating bkpcabal08-0.1.0.0-LjROTJ30vjpHLvYNUnY1dD-p
Preprocessing library 'q' for bkpcabal08-0.1.0.0...
Building library 'q' instantiated with
- A = bkpcabal08-0.1.0.0-5HJrxUERN7CD204UZeT4Ws-impl:A
- B = bkpcabal08-0.1.0.0-5HJrxUERN7CD204UZeT4Ws-impl:B
+ A = bkpcabal08-0.1.0.0-KxkxGUgMJM6Dqo87AQu6V5-impl:A
+ B = bkpcabal08-0.1.0.0-KxkxGUgMJM6Dqo87AQu6V5-impl:B
for bkpcabal08-0.1.0.0...
-[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-1DQJ9DKc4h59P07qcb0kBc-q+J5mAfRWG9IgLmFQVftCb8t/A.o ) [Prelude package changed]
-[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-1DQJ9DKc4h59P07qcb0kBc-q+J5mAfRWG9IgLmFQVftCb8t/B.o ) [Prelude package changed]
+[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-9Cd344YIpXKFRnHN0O8bjR-q+BXOBBkqkS8ELakzWUKHCOx/A.o ) [Prelude package changed]
+[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-9Cd344YIpXKFRnHN0O8bjR-q+BXOBBkqkS8ELakzWUKHCOx/B.o ) [Prelude package changed]
Preprocessing library 'r' for bkpcabal08-0.1.0.0...
Building library 'r' for bkpcabal08-0.1.0.0...
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6693,6 +6694,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6665,6 +6666,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -4610,6 +4610,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6836,6 +6837,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6693,6 +6694,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -5873,6 +5873,7 @@ module GHC.PrimOps where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -10916,6 +10917,16 @@ module Prelude.Experimental where
data Unit# = ...
getSolo :: forall a. Solo a -> a
+module System.Mem.Experimental where
+ -- Safety: None
+ type AllocationLimitKillBehaviour :: *
+ data AllocationLimitKillBehaviour = KillOnAllocationLimit | DontKillOnAllocationLimit
+ disableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO GHC.Internal.Int.Int64
+ setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()) -> GHC.Internal.Types.IO ()
+
-- Instances:
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
=====================================
@@ -5876,6 +5876,7 @@ module GHC.PrimOps where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -10919,6 +10920,16 @@ module Prelude.Experimental where
data Unit# = ...
getSolo :: forall a. Solo a -> a
+module System.Mem.Experimental where
+ -- Safety: None
+ type AllocationLimitKillBehaviour :: *
+ data AllocationLimitKillBehaviour = KillOnAllocationLimit | DontKillOnAllocationLimit
+ disableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO GHC.Internal.Int.Int64
+ setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()) -> GHC.Internal.Types.IO ()
+
-- Instances:
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/interface-stability/ghc-prim-exports.stdout
=====================================
@@ -2505,6 +2505,7 @@ module GHC.Prim where
seq :: forall {r :: GHC.Internal.Types.RuntimeRep} a (b :: TYPE r). a -> b -> b
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shrinkMutableByteArray# :: forall d. MutableByteArray# d -> Int# -> State# d -> State# d
shrinkSmallMutableArray# :: forall {l :: GHC.Internal.Types.Levity} d (a :: TYPE (GHC.Internal.Types.BoxedRep l)). SmallMutableArray# d a -> Int# -> State# d -> State# d
@@ -3489,6 +3490,7 @@ module GHC.PrimopWrappers where
retry# :: forall a_levpoly. GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, a_levpoly #)
setAddrRange# :: GHC.Internal.Prim.Addr# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
+ setOtherThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.ThreadId# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
shrinkMutableByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
shrinkSmallMutableArray# :: forall s a_levpoly. GHC.Internal.Prim.SmallMutableArray# s a_levpoly -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
=====================================
testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
=====================================
@@ -2505,6 +2505,7 @@ module GHC.Prim where
seq :: forall {r :: GHC.Internal.Types.RuntimeRep} a (b :: TYPE r). a -> b -> b
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shrinkMutableByteArray# :: forall d. MutableByteArray# d -> Int# -> State# d -> State# d
shrinkSmallMutableArray# :: forall {l :: GHC.Internal.Types.Levity} d (a :: TYPE (GHC.Internal.Types.BoxedRep l)). SmallMutableArray# d a -> Int# -> State# d -> State# d
@@ -3492,6 +3493,7 @@ module GHC.PrimopWrappers where
retry# :: forall a_levpoly. GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, a_levpoly #)
setAddrRange# :: GHC.Internal.Prim.Addr# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
+ setOtherThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.ThreadId# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
shrinkMutableByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
shrinkSmallMutableArray# :: forall s a_levpoly. GHC.Internal.Prim.SmallMutableArray# s a_levpoly -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
=====================================
testsuite/tests/rts/T22859.hs
=====================================
@@ -0,0 +1,72 @@
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Control.Exception
+import Control.Exception.Backtrace
+import Control.Concurrent
+import Control.Concurrent.MVar
+import System.Mem
+import System.Mem.Experimental
+import GHC.IO (IO (..))
+import GHC.Exts
+import System.IO
+
+-- | Just do some work and hPutStrLn to stderr to indicate that we are making progress
+worker :: IO ()
+worker = loop [] 2
+ where
+ loop !m !n
+ | n > 30 = hPutStrLn stderr . show $ length m
+ | otherwise = do
+ let x = show n
+ hPutStrLn stderr x
+ -- just to bulk out the allocations
+ IO (\s -> case newByteArray# 900000# s of (# s', arr# #) -> (# s', () #))
+ yield
+ loop (x:m) (n + 1)
+
+main :: IO ()
+main = do
+ hSetBuffering stderr LineBuffering -- necessary for Windows, otherwise our output gets garbled
+ done <- newMVar () -- we use this lock to wait for the worker to finish
+ started <- newEmptyMVar
+ let runWorker = do
+ forkIO . withMVar done $ \_ -> flip onException (hPutStrLn stderr "worker died") $ do
+ hPutStrLn stderr "worker starting"
+ putMVar started ()
+ setAllocationCounter 1_000_000
+ enableAllocationLimit
+ worker
+ hPutStrLn stderr "worker done"
+ takeMVar started
+ readMVar done
+ hFlush stderr
+ threadDelay 1000
+ -- default behaviour:
+ -- kill it after the limit is exceeded
+ hPutStrLn stderr "default behaviour"
+ runWorker
+ hPutStrLn stderr "just log once on the hook being triggered"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 1")
+ runWorker
+ hPutStrLn stderr "just log on the hook being triggered"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tid -> do
+ hPutStrLn stderr "allocation limit triggered 2"
+ -- re-enable the hook
+ setAllocationCounterFor 1_000_000 tid
+ enableAllocationLimitFor tid
+ runWorker
+ hPutStrLn stderr "kill from the hook"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tId -> throwTo tId AllocationLimitExceeded
+ runWorker
+ -- not super helpful, but let's test it anyway
+ hPutStrLn stderr "do nothing"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit Nothing
+ runWorker
+ -- this is possible to handle using an exception handler instead.
+ hPutStrLn stderr "kill and log"
+ setGlobalAllocationLimitHandler KillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 3")
+ runWorker
+ threadDelay 1000
+ hPutStrLn stderr "done"
=====================================
testsuite/tests/rts/T22859.stderr
=====================================
@@ -0,0 +1,140 @@
+default behaviour
+worker starting
+2
+3
+worker died
+T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException:
+
+allocation limit exceeded
+just log once on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 1
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+just log on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 2
+4
+5
+allocation limit triggered 2
+6
+7
+allocation limit triggered 2
+8
+9
+allocation limit triggered 2
+10
+11
+allocation limit triggered 2
+12
+13
+allocation limit triggered 2
+14
+15
+allocation limit triggered 2
+16
+17
+allocation limit triggered 2
+18
+19
+allocation limit triggered 2
+20
+21
+allocation limit triggered 2
+22
+23
+allocation limit triggered 2
+24
+25
+allocation limit triggered 2
+26
+27
+allocation limit triggered 2
+28
+29
+allocation limit triggered 2
+30
+29
+worker done
+kill from the hook
+worker starting
+2
+3
+worker died
+T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException:
+
+allocation limit exceeded
+do nothing
+worker starting
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+kill and log
+worker starting
+2
+3
+allocation limit triggered 3
+worker died
+T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException:
+
+allocation limit exceeded
+done
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -643,3 +643,8 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru
test('T25560', [req_c_rts, ignore_stderr], compile_and_run, [''])
test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main'])
+test('T22859',
+ [js_skip,
+ # Allocation behaviour differs with the wasm backend so we get different output
+ when(arch('wasm32'), skip)]],
+ compile_and_run, ['-with-rtsopts -A8K'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fd88237a955c147e8135d06035b33cf…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fd88237a955c147e8135d06035b33cf…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T22859] Implement user-defined allocation limit handlers
by Teo Camarasu (＠teo) 07 Jul '25
by Teo Camarasu (＠teo) 07 Jul '25
07 Jul '25
Teo Camarasu pushed to branch wip/T22859 at Glasgow Haskell Compiler / GHC
Commits:
f6a7fccb by Teo Camarasu at 2025-07-06T18:48:12+01:00
Implement user-defined allocation limit handlers
Allocation Limits allow killing a thread if they allocate more than a
user-specified limit.
We extend this feature to allow more versatile behaviour.
- We allow not killing the thread if the limit is exceeded.
- We allow setting a custom handler to be called when the limit is exceeded.
User-specified allocation limit handlers run in a fresh thread and are passed
the ThreadId of the thread that exceeded its limit.
We introduce utility functions for getting and setting the allocation
limits of other threads, so that users can reset the limit of a thread
from a handler. Both of these are somewhat coarse-grained as we are
unaware of the allocations in the current nursery chunk.
We provide several examples of usages in testsuite/tests/rts/T22859.hs
Resolves #22859
- - - - -
28 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/ghc-experimental/ghc-experimental.cabal.in
- + libraries/ghc-experimental/src/System/Mem/Experimental.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/external-symbols.list.in
- rts/include/rts/storage/GC.h
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- + testsuite/tests/rts/T22859.hs
- + testsuite/tests/rts/T22859.stderr
- testsuite/tests/rts/all.T
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -4065,6 +4065,15 @@ primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp
effect = ReadWriteEffect
out_of_line = True
+primop SetOtherThreadAllocationCounter "setOtherThreadAllocationCounter#" GenPrimOp
+ Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
+ { Sets the allocation counter for the another thread to the given value.
+ This doesn't take allocations into the current nursery chunk into account.
+ Therefore it is only accurate if the other thread is not currently running. }
+ with
+ effect = ReadWriteEffect
+ out_of_line = True
+
primtype StackSnapshot#
{ Haskell representation of a @StgStack*@ that was created (cloned)
with a function in "GHC.Stack.CloneStack". Please check the
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1775,6 +1775,7 @@ emitPrimOp cfg primop =
TraceEventBinaryOp -> alwaysExternal
TraceMarkerOp -> alwaysExternal
SetThreadAllocationCounter -> alwaysExternal
+ SetOtherThreadAllocationCounter -> alwaysExternal
KeepAliveOp -> alwaysExternal
where
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1173,6 +1173,7 @@ genPrim prof bound ty op = case op of
WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n
SetThreadAllocationCounter -> unhandledPrimop op
+ SetOtherThreadAllocationCounter -> unhandledPrimop op
------------------------------- Vector -----------------------------------------
-- For now, vectors are unsupported on the JS backend. Simply put, they do not
=====================================
libraries/ghc-experimental/ghc-experimental.cabal.in
=====================================
@@ -38,6 +38,7 @@ library
GHC.RTS.Flags.Experimental
GHC.Stats.Experimental
Prelude.Experimental
+ System.Mem.Experimental
if arch(wasm32)
exposed-modules: GHC.Wasm.Prim
other-extensions:
=====================================
libraries/ghc-experimental/src/System/Mem/Experimental.hs
=====================================
@@ -0,0 +1,10 @@
+module System.Mem.Experimental
+ ( setGlobalAllocationLimitHandler
+ , AllocationLimitKillBehaviour(..)
+ , getAllocationCounterFor
+ , setAllocationCounterFor
+ , enableAllocationLimitFor
+ , disableAllocationLimitFor
+ )
+ where
+import GHC.Internal.AllocationLimitHandler
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -122,6 +122,7 @@ Library
rts == 1.0.*
exposed-modules:
+ GHC.Internal.AllocationLimitHandler
GHC.Internal.ClosureTypes
GHC.Internal.Control.Arrow
GHC.Internal.Control.Category
=====================================
libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
=====================================
@@ -0,0 +1,117 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# OPTIONS_HADDOCK not-home #-}
+module GHC.Internal.AllocationLimitHandler
+ ( runAllocationLimitHandler
+ , setGlobalAllocationLimitHandler
+ , AllocationLimitKillBehaviour(..)
+ , getAllocationCounterFor
+ , setAllocationCounterFor
+ , enableAllocationLimitFor
+ , disableAllocationLimitFor
+ )
+ where
+import GHC.Internal.Base
+import GHC.Internal.Conc.Sync (ThreadId(..))
+import GHC.Internal.Data.IORef (IORef, readIORef, writeIORef, newIORef)
+import GHC.Internal.Foreign.C.Types
+import GHC.Internal.IO (unsafePerformIO)
+import GHC.Internal.Int (Int64(..))
+
+
+{-# NOINLINE allocationLimitHandler #-}
+allocationLimitHandler :: IORef (ThreadId -> IO ())
+allocationLimitHandler = unsafePerformIO (newIORef defaultHandler)
+
+defaultHandler :: ThreadId -> IO ()
+defaultHandler _ = pure ()
+
+foreign import ccall "setAllocLimitKill" setAllocLimitKill :: CBool -> CBool -> IO ()
+
+runAllocationLimitHandler :: ThreadId# -> IO ()
+runAllocationLimitHandler tid = do
+ hook <- getAllocationLimitHandler
+ hook $ ThreadId tid
+
+getAllocationLimitHandler :: IO (ThreadId -> IO ())
+getAllocationLimitHandler = readIORef allocationLimitHandler
+
+data AllocationLimitKillBehaviour =
+ KillOnAllocationLimit
+ -- ^ Throw a @AllocationLimitExceeded@ async exception to the thread when the
+ -- allocation limit is exceeded.
+ | DontKillOnAllocationLimit
+ -- ^ Do not throw an exception when the allocation limit is exceeded.
+
+-- | Define the behaviour for handling allocation limits.
+-- The default behaviour is to throw an @AllocationLimitExceeded@ async exception to the thread.
+-- This can be overriden using @AllocationLimitKillBehaviour@.
+--
+-- We can set a user-specified handler, which can be run in addition to
+-- or in place of the exception.
+-- This allows for instance logging on the allocation limit being exceeded,
+-- or dynamically determining whether to terminate the thread.
+-- The handler is not guaranteed to run before the thread is terminated or restarted.
+--
+-- Note: that if you don't terminate the thread, then the allocation limit gets
+-- removed.
+-- If you wish to keep the allocation limit you will have to reset it using
+-- @setAllocationCounter@ and @enableAllocationLimit@.
+setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> Maybe (ThreadId -> IO ()) -> IO ()
+setGlobalAllocationLimitHandler killBehaviour mHandler = do
+ shouldRunHandler <- case mHandler of
+ Just hook -> do
+ writeIORef allocationLimitHandler hook
+ pure 1
+ Nothing -> do
+ writeIORef allocationLimitHandler defaultHandler
+ pure 0
+ let shouldKill =
+ case killBehaviour of
+ KillOnAllocationLimit -> 1
+ DontKillOnAllocationLimit -> 0
+ setAllocLimitKill shouldKill shouldRunHandler
+
+-- | Retrieves the allocation counter for the another thread.
+foreign import prim "stg_getOtherThreadAllocationCounterzh" getOtherThreadAllocationCounter#
+ :: ThreadId#
+ -> State# RealWorld
+ -> (# State# RealWorld, Int64# #)
+
+-- | Get the allocation counter for a different thread.
+--
+-- Note: this doesn't take the current nursery chunk into account.
+-- If the thread is running then it may underestimate allocations by the size of a nursery thread.
+getAllocationCounterFor :: ThreadId -> IO Int64
+getAllocationCounterFor (ThreadId t#) = IO $ \s ->
+ case getOtherThreadAllocationCounter# t# s of (# s', i# #) -> (# s', I64# i# #)
+
+-- | Set the allocation counter for a different thread.
+-- This can be combined with 'enableAllocationLimitFor' to enable allocation limits for another thread.
+-- You may wish to do this during a user-specified allocation limit handler.
+--
+-- Note: this doesn't take the current nursery chunk into account.
+-- If the thread is running then it may overestimate allocations by the size of a nursery thread,
+-- and trigger the limit sooner than expected.
+setAllocationCounterFor :: Int64 -> ThreadId -> IO ()
+setAllocationCounterFor (I64# i#) (ThreadId t#) = IO $ \s ->
+ case setOtherThreadAllocationCounter# i# t# s of s' -> (# s', () #)
+
+
+-- | Enable allocation limit processing the thread @t@.
+enableAllocationLimitFor :: ThreadId -> IO ()
+enableAllocationLimitFor (ThreadId t) = do
+ rts_enableThreadAllocationLimit t
+
+-- | Disable allocation limit processing the thread @t@.
+disableAllocationLimitFor :: ThreadId -> IO ()
+disableAllocationLimitFor (ThreadId t) = do
+ rts_disableThreadAllocationLimit t
+
+foreign import ccall unsafe "rts_enableThreadAllocationLimit"
+ rts_enableThreadAllocationLimit :: ThreadId# -> IO ()
+
+foreign import ccall unsafe "rts_disableThreadAllocationLimit"
+ rts_disableThreadAllocationLimit :: ThreadId# -> IO ()
=====================================
rts/Prelude.h
=====================================
@@ -67,6 +67,7 @@ PRELUDE_CLOSURE(ghczminternal_GHCziInternalziEventziWindows_processRemoteComplet
PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure);
PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure);
+PRELUDE_CLOSURE(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure);
PRELUDE_INFO(ghczminternal_GHCziInternalziCString_unpackCStringzh_info);
PRELUDE_INFO(ghczminternal_GHCziInternalziTypes_Czh_con_info);
@@ -102,6 +103,7 @@ PRELUDE_INFO(ghczminternal_GHCziInternalziStable_StablePtr_con_info);
#if defined(mingw32_HOST_OS)
#define processRemoteCompletion_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziEventziWindows_processRemoteCompletion_closure)
#endif
+#define runAllocationLimitHandler_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure)
#define flushStdHandles_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure)
#define runMainIO_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure)
=====================================
rts/PrimOps.cmm
=====================================
@@ -2889,6 +2889,11 @@ stg_getThreadAllocationCounterzh ()
return (StgTSO_alloc_limit(CurrentTSO) - TO_I64(offset));
}
+stg_getOtherThreadAllocationCounterzh ( gcptr t )
+{
+ return (StgTSO_alloc_limit(t));
+}
+
stg_setThreadAllocationCounterzh ( I64 counter )
{
// Allocation in the current block will be subtracted by
@@ -2901,6 +2906,12 @@ stg_setThreadAllocationCounterzh ( I64 counter )
return ();
}
+stg_setOtherThreadAllocationCounterzh ( I64 counter, gcptr t )
+{
+ StgTSO_alloc_limit(t) = counter;
+ return ();
+}
+
#define KEEP_ALIVE_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,c) \
w_ info_ptr, \
=====================================
rts/RtsStartup.c
=====================================
@@ -224,6 +224,7 @@ static void initBuiltinGcRoots(void)
* GHC.Core.Make.mkExceptionId.
*/
getStablePtr((StgPtr)absentSumFieldError_closure);
+ getStablePtr((StgPtr)runAllocationLimitHandler_closure);
}
void
=====================================
rts/RtsSymbols.c
=====================================
@@ -748,6 +748,7 @@ extern char **environ;
SymI_HasProto(rts_enableThreadAllocationLimit) \
SymI_HasProto(rts_disableThreadAllocationLimit) \
SymI_HasProto(rts_setMainThread) \
+ SymI_HasProto(setAllocLimitKill) \
SymI_HasProto(setProgArgv) \
SymI_HasProto(startupHaskell) \
SymI_HasProto(shutdownHaskell) \
@@ -916,7 +917,9 @@ extern char **environ;
SymI_HasDataProto(stg_traceMarkerzh) \
SymI_HasDataProto(stg_traceBinaryEventzh) \
SymI_HasDataProto(stg_getThreadAllocationCounterzh) \
+ SymI_HasDataProto(stg_getOtherThreadAllocationCounterzh) \
SymI_HasDataProto(stg_setThreadAllocationCounterzh) \
+ SymI_HasDataProto(stg_setOtherThreadAllocationCounterzh) \
SymI_HasProto(getMonotonicNSec) \
SymI_HasProto(lockFile) \
SymI_HasProto(unlockFile) \
=====================================
rts/Schedule.c
=====================================
@@ -41,6 +41,7 @@
#include "Threads.h"
#include "Timer.h"
#include "ThreadPaused.h"
+#include "ThreadLabels.h"
#include "Messages.h"
#include "StablePtr.h"
#include "StableName.h"
@@ -94,6 +95,10 @@ StgWord recent_activity = ACTIVITY_YES;
*/
StgWord sched_state = SCHED_RUNNING;
+
+bool allocLimitKill = true;
+bool allocLimitRunHook = false;
+
/*
* This mutex protects most of the global scheduler data in
* the THREADED_RTS runtime.
@@ -1125,19 +1130,36 @@ schedulePostRunThread (Capability *cap, StgTSO *t)
}
}
- //
- // If the current thread's allocation limit has run out, send it
- // the AllocationLimitExceeded exception.
+ // Handle the current thread's allocation limit running out,
if (PK_Int64((W_*)&(t->alloc_limit)) < 0 && (t->flags & TSO_ALLOC_LIMIT)) {
- // Use a throwToSelf rather than a throwToSingleThreaded, because
- // it correctly handles the case where the thread is currently
- // inside mask. Also the thread might be blocked (e.g. on an
- // MVar), and throwToSingleThreaded doesn't unblock it
- // correctly in that case.
- throwToSelf(cap, t, allocationLimitExceeded_closure);
- ASSIGN_Int64((W_*)&(t->alloc_limit),
- (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+ if(allocLimitKill) {
+ // Throw the AllocationLimitExceeded exception.
+ // Use a throwToSelf rather than a throwToSingleThreaded, because
+ // it correctly handles the case where the thread is currently
+ // inside mask. Also the thread might be blocked (e.g. on an
+ // MVar), and throwToSingleThreaded doesn't unblock it
+ // correctly in that case.
+ throwToSelf(cap, t, allocationLimitExceeded_closure);
+ ASSIGN_Int64((W_*)&(t->alloc_limit),
+ (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+ } else {
+ // If we aren't killing the thread, we must disable the limit
+ // otherwise we will immediatelly retrigger it.
+ // User defined handlers should re-enable it if wanted.
+ t->flags = t->flags & ~TSO_ALLOC_LIMIT;
+ }
+
+ if(allocLimitRunHook)
+ {
+ // Create a thread to run the allocation limit handler.
+ StgClosure* c = rts_apply(cap, runAllocationLimitHandler_closure, (StgClosure*)t);
+ StgTSO* hookThread = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, c);
+ setThreadLabel(cap, hookThread, "allocation limit handler thread");
+ // Schedule the handler to be run immediatelly.
+ pushOnRunQueue(cap, hookThread);
+ }
+
}
/* some statistics gathering in the parallel case */
@@ -3342,3 +3364,9 @@ resurrectThreads (StgTSO *threads)
}
}
}
+
+void setAllocLimitKill(bool shouldKill, bool shouldHook)
+{
+ allocLimitKill = shouldKill;
+ allocLimitRunHook = shouldHook;
+}
=====================================
rts/external-symbols.list.in
=====================================
@@ -43,6 +43,7 @@ ghczminternal_GHCziInternalziTypes_Izh_con_info
ghczminternal_GHCziInternalziTypes_Fzh_con_info
ghczminternal_GHCziInternalziTypes_Dzh_con_info
ghczminternal_GHCziInternalziTypes_Wzh_con_info
+ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure
ghczminternal_GHCziInternalziPtr_Ptr_con_info
ghczminternal_GHCziInternalziPtr_FunPtr_con_info
ghczminternal_GHCziInternalziInt_I8zh_con_info
=====================================
rts/include/rts/storage/GC.h
=====================================
@@ -209,6 +209,10 @@ void flushExec(W_ len, AdjustorExecutable exec_addr);
// Used by GC checks in external .cmm code:
extern W_ large_alloc_lim;
+// Should triggering an allocation limit kill the thread
+// and should we run a user-defined hook when it is triggered.
+void setAllocLimitKill(bool, bool);
+
/* -----------------------------------------------------------------------------
Performing Garbage Collection
-------------------------------------------------------------------------- */
=====================================
rts/include/rts/storage/TSO.h
=====================================
@@ -157,9 +157,10 @@ typedef struct StgTSO_ {
/*
* The allocation limit for this thread, which is updated as the
* thread allocates. If the value drops below zero, and
- * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the
- * thread, and give the thread a little more space to handle the
- * exception before we raise the exception again.
+ * TSO_ALLOC_LIMIT is set in flags, then a handler is triggerd.
+ * Either we raise an exception in the thread, and give the thread
+ * a little more space to handle the exception before we raise the
+ * exception again; or we run a user defined handler.
*
* This is an integer, because we might update it in a place where
* it isn't convenient to raise the exception, so we want it to
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -604,7 +604,9 @@ RTS_FUN_DECL(stg_traceEventzh);
RTS_FUN_DECL(stg_traceBinaryEventzh);
RTS_FUN_DECL(stg_traceMarkerzh);
RTS_FUN_DECL(stg_getThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_getOtherThreadAllocationCounterzh);
RTS_FUN_DECL(stg_setThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_setOtherThreadAllocationCounterzh);
RTS_FUN_DECL(stg_castWord64ToDoublezh);
RTS_FUN_DECL(stg_castDoubleToWord64zh);
=====================================
testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
=====================================
@@ -13,13 +13,13 @@ Building library 'q' instantiated with
for bkpcabal08-0.1.0.0...
[2 of 4] Compiling B[sig] ( q/B.hsig, nothing )
[3 of 4] Compiling M ( q/M.hs, nothing ) [A changed]
-[4 of 4] Instantiating bkpcabal08-0.1.0.0-CoQJNXLfoYQ4TyvApzFHv-p
+[4 of 4] Instantiating bkpcabal08-0.1.0.0-LjROTJ30vjpHLvYNUnY1dD-p
Preprocessing library 'q' for bkpcabal08-0.1.0.0...
Building library 'q' instantiated with
- A = bkpcabal08-0.1.0.0-5HJrxUERN7CD204UZeT4Ws-impl:A
- B = bkpcabal08-0.1.0.0-5HJrxUERN7CD204UZeT4Ws-impl:B
+ A = bkpcabal08-0.1.0.0-KxkxGUgMJM6Dqo87AQu6V5-impl:A
+ B = bkpcabal08-0.1.0.0-KxkxGUgMJM6Dqo87AQu6V5-impl:B
for bkpcabal08-0.1.0.0...
-[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-1DQJ9DKc4h59P07qcb0kBc-q+J5mAfRWG9IgLmFQVftCb8t/A.o ) [Prelude package changed]
-[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-1DQJ9DKc4h59P07qcb0kBc-q+J5mAfRWG9IgLmFQVftCb8t/B.o ) [Prelude package changed]
+[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-9Cd344YIpXKFRnHN0O8bjR-q+BXOBBkqkS8ELakzWUKHCOx/A.o ) [Prelude package changed]
+[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-9Cd344YIpXKFRnHN0O8bjR-q+BXOBBkqkS8ELakzWUKHCOx/B.o ) [Prelude package changed]
Preprocessing library 'r' for bkpcabal08-0.1.0.0...
Building library 'r' for bkpcabal08-0.1.0.0...
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6693,6 +6694,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6665,6 +6666,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -4610,6 +4610,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6836,6 +6837,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6693,6 +6694,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -5873,6 +5873,7 @@ module GHC.PrimOps where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -10916,6 +10917,16 @@ module Prelude.Experimental where
data Unit# = ...
getSolo :: forall a. Solo a -> a
+module System.Mem.Experimental where
+ -- Safety: None
+ type AllocationLimitKillBehaviour :: *
+ data AllocationLimitKillBehaviour = KillOnAllocationLimit | DontKillOnAllocationLimit
+ disableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO GHC.Internal.Int.Int64
+ setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()) -> GHC.Internal.Types.IO ()
+
-- Instances:
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
=====================================
@@ -5876,6 +5876,7 @@ module GHC.PrimOps where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -10919,6 +10920,16 @@ module Prelude.Experimental where
data Unit# = ...
getSolo :: forall a. Solo a -> a
+module System.Mem.Experimental where
+ -- Safety: None
+ type AllocationLimitKillBehaviour :: *
+ data AllocationLimitKillBehaviour = KillOnAllocationLimit | DontKillOnAllocationLimit
+ disableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO GHC.Internal.Int.Int64
+ setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()) -> GHC.Internal.Types.IO ()
+
-- Instances:
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/interface-stability/ghc-prim-exports.stdout
=====================================
@@ -2505,6 +2505,7 @@ module GHC.Prim where
seq :: forall {r :: GHC.Internal.Types.RuntimeRep} a (b :: TYPE r). a -> b -> b
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shrinkMutableByteArray# :: forall d. MutableByteArray# d -> Int# -> State# d -> State# d
shrinkSmallMutableArray# :: forall {l :: GHC.Internal.Types.Levity} d (a :: TYPE (GHC.Internal.Types.BoxedRep l)). SmallMutableArray# d a -> Int# -> State# d -> State# d
@@ -3489,6 +3490,7 @@ module GHC.PrimopWrappers where
retry# :: forall a_levpoly. GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, a_levpoly #)
setAddrRange# :: GHC.Internal.Prim.Addr# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
+ setOtherThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.ThreadId# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
shrinkMutableByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
shrinkSmallMutableArray# :: forall s a_levpoly. GHC.Internal.Prim.SmallMutableArray# s a_levpoly -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
=====================================
testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
=====================================
@@ -2505,6 +2505,7 @@ module GHC.Prim where
seq :: forall {r :: GHC.Internal.Types.RuntimeRep} a (b :: TYPE r). a -> b -> b
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shrinkMutableByteArray# :: forall d. MutableByteArray# d -> Int# -> State# d -> State# d
shrinkSmallMutableArray# :: forall {l :: GHC.Internal.Types.Levity} d (a :: TYPE (GHC.Internal.Types.BoxedRep l)). SmallMutableArray# d a -> Int# -> State# d -> State# d
@@ -3492,6 +3493,7 @@ module GHC.PrimopWrappers where
retry# :: forall a_levpoly. GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, a_levpoly #)
setAddrRange# :: GHC.Internal.Prim.Addr# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
+ setOtherThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.ThreadId# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
shrinkMutableByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
shrinkSmallMutableArray# :: forall s a_levpoly. GHC.Internal.Prim.SmallMutableArray# s a_levpoly -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
=====================================
testsuite/tests/rts/T22859.hs
=====================================
@@ -0,0 +1,72 @@
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Control.Exception
+import Control.Exception.Backtrace
+import Control.Concurrent
+import Control.Concurrent.MVar
+import System.Mem
+import System.Mem.Experimental
+import GHC.IO (IO (..))
+import GHC.Exts
+import System.IO
+
+-- | Just do some work and hPutStrLn to stderr to indicate that we are making progress
+worker :: IO ()
+worker = loop [] 2
+ where
+ loop !m !n
+ | n > 30 = hPutStrLn stderr . show $ length m
+ | otherwise = do
+ let x = show n
+ hPutStrLn stderr x
+ -- just to bulk out the allocations
+ IO (\s -> case newByteArray# 900000# s of (# s', arr# #) -> (# s', () #))
+ yield
+ loop (x:m) (n + 1)
+
+main :: IO ()
+main = do
+ hSetBuffering stderr LineBuffering -- necessary for Windows, otherwise our output gets garbled
+ done <- newMVar () -- we use this lock to wait for the worker to finish
+ started <- newEmptyMVar
+ let runWorker = do
+ forkIO . withMVar done $ \_ -> flip onException (hPutStrLn stderr "worker died") $ do
+ hPutStrLn stderr "worker starting"
+ putMVar started ()
+ setAllocationCounter 1_000_000
+ enableAllocationLimit
+ worker
+ hPutStrLn stderr "worker done"
+ takeMVar started
+ readMVar done
+ hFlush stderr
+ threadDelay 1000
+ -- default behaviour:
+ -- kill it after the limit is exceeded
+ hPutStrLn stderr "default behaviour"
+ runWorker
+ hPutStrLn stderr "just log once on the hook being triggered"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 1")
+ runWorker
+ hPutStrLn stderr "just log on the hook being triggered"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tid -> do
+ hPutStrLn stderr "allocation limit triggered 2"
+ -- re-enable the hook
+ setAllocationCounterFor 1_000_000 tid
+ enableAllocationLimitFor tid
+ runWorker
+ hPutStrLn stderr "kill from the hook"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tId -> throwTo tId AllocationLimitExceeded
+ runWorker
+ -- not super helpful, but let's test it anyway
+ hPutStrLn stderr "do nothing"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit Nothing
+ runWorker
+ -- this is possible to handle using an exception handler instead.
+ hPutStrLn stderr "kill and log"
+ setGlobalAllocationLimitHandler KillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 3")
+ runWorker
+ threadDelay 1000
+ hPutStrLn stderr "done"
=====================================
testsuite/tests/rts/T22859.stderr
=====================================
@@ -0,0 +1,140 @@
+default behaviour
+worker starting
+2
+3
+worker died
+T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException:
+
+allocation limit exceeded
+just log once on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 1
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+just log on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 2
+4
+5
+allocation limit triggered 2
+6
+7
+allocation limit triggered 2
+8
+9
+allocation limit triggered 2
+10
+11
+allocation limit triggered 2
+12
+13
+allocation limit triggered 2
+14
+15
+allocation limit triggered 2
+16
+17
+allocation limit triggered 2
+18
+19
+allocation limit triggered 2
+20
+21
+allocation limit triggered 2
+22
+23
+allocation limit triggered 2
+24
+25
+allocation limit triggered 2
+26
+27
+allocation limit triggered 2
+28
+29
+allocation limit triggered 2
+30
+29
+worker done
+kill from the hook
+worker starting
+2
+3
+worker died
+T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException:
+
+allocation limit exceeded
+do nothing
+worker starting
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+kill and log
+worker starting
+2
+3
+allocation limit triggered 3
+worker died
+T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException:
+
+allocation limit exceeded
+done
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -643,3 +643,8 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru
test('T25560', [req_c_rts, ignore_stderr], compile_and_run, [''])
test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main'])
+test('T22859',
+ [ js_skip
+ # Allocation behaviour differs with the wasm backend so we get different output
+ , when(arch('wasm32'), skip)]
+ ], compile_and_run, ['-with-rtsopts -A8K'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f6a7fccbdae959d5c7130f4583da6e2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f6a7fccbdae959d5c7130f4583da6e2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T22859] Implement user-defined allocation limit handlers
by Teo Camarasu (＠teo) 06 Jul '25
by Teo Camarasu (＠teo) 06 Jul '25
06 Jul '25
Teo Camarasu pushed to branch wip/T22859 at Glasgow Haskell Compiler / GHC
Commits:
7211bc5e by Teo Camarasu at 2025-07-06T16:25:54+01:00
Implement user-defined allocation limit handlers
Allocation Limits allow killing a thread if they allocate more than a
user-specified limit.
We extend this feature to allow more versatile behaviour.
- We allow not killing the thread if the limit is exceeded.
- We allow setting a custom handler to be called when the limit is exceeded.
User-specified allocation limit handlers run in a fresh thread and are passed
the ThreadId of the thread that exceeded its limit.
We introduce utility functions for getting and setting the allocation
limits of other threads, so that users can reset the limit of a thread
from a handler. Both of these are somewhat coarse-grained as we are
unaware of the allocations in the current nursery chunk.
We provide several examples of usages in testsuite/tests/rts/T22859.hs
Resolves #22859
- - - - -
28 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/ghc-experimental/ghc-experimental.cabal.in
- + libraries/ghc-experimental/src/System/Mem/Experimental.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/external-symbols.list.in
- rts/include/rts/storage/GC.h
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- + testsuite/tests/rts/T22859.hs
- + testsuite/tests/rts/T22859.stderr
- testsuite/tests/rts/all.T
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -4065,6 +4065,15 @@ primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp
effect = ReadWriteEffect
out_of_line = True
+primop SetOtherThreadAllocationCounter "setOtherThreadAllocationCounter#" GenPrimOp
+ Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
+ { Sets the allocation counter for the another thread to the given value.
+ This doesn't take allocations into the current nursery chunk into account.
+ Therefore it is only accurate if the other thread is not currently running. }
+ with
+ effect = ReadWriteEffect
+ out_of_line = True
+
primtype StackSnapshot#
{ Haskell representation of a @StgStack*@ that was created (cloned)
with a function in "GHC.Stack.CloneStack". Please check the
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1775,6 +1775,7 @@ emitPrimOp cfg primop =
TraceEventBinaryOp -> alwaysExternal
TraceMarkerOp -> alwaysExternal
SetThreadAllocationCounter -> alwaysExternal
+ SetOtherThreadAllocationCounter -> alwaysExternal
KeepAliveOp -> alwaysExternal
where
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1173,6 +1173,7 @@ genPrim prof bound ty op = case op of
WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n
SetThreadAllocationCounter -> unhandledPrimop op
+ SetOtherThreadAllocationCounter -> unhandledPrimop op
------------------------------- Vector -----------------------------------------
-- For now, vectors are unsupported on the JS backend. Simply put, they do not
=====================================
libraries/ghc-experimental/ghc-experimental.cabal.in
=====================================
@@ -38,6 +38,7 @@ library
GHC.RTS.Flags.Experimental
GHC.Stats.Experimental
Prelude.Experimental
+ System.Mem.Experimental
if arch(wasm32)
exposed-modules: GHC.Wasm.Prim
other-extensions:
=====================================
libraries/ghc-experimental/src/System/Mem/Experimental.hs
=====================================
@@ -0,0 +1,10 @@
+module System.Mem.Experimental
+ ( setGlobalAllocationLimitHandler
+ , AllocationLimitKillBehaviour(..)
+ , getAllocationCounterFor
+ , setAllocationCounterFor
+ , enableAllocationLimitFor
+ , disableAllocationLimitFor
+ )
+ where
+import GHC.Internal.AllocationLimitHandler
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -122,6 +122,7 @@ Library
rts == 1.0.*
exposed-modules:
+ GHC.Internal.AllocationLimitHandler
GHC.Internal.ClosureTypes
GHC.Internal.Control.Arrow
GHC.Internal.Control.Category
=====================================
libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
=====================================
@@ -0,0 +1,117 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# OPTIONS_HADDOCK not-home #-}
+module GHC.Internal.AllocationLimitHandler
+ ( runAllocationLimitHandler
+ , setGlobalAllocationLimitHandler
+ , AllocationLimitKillBehaviour(..)
+ , getAllocationCounterFor
+ , setAllocationCounterFor
+ , enableAllocationLimitFor
+ , disableAllocationLimitFor
+ )
+ where
+import GHC.Internal.Base
+import GHC.Internal.Conc.Sync (ThreadId(..))
+import GHC.Internal.Data.IORef (IORef, readIORef, writeIORef, newIORef)
+import GHC.Internal.Foreign.C.Types
+import GHC.Internal.IO (unsafePerformIO)
+import GHC.Internal.Int (Int64(..))
+
+
+{-# NOINLINE allocationLimitHandler #-}
+allocationLimitHandler :: IORef (ThreadId -> IO ())
+allocationLimitHandler = unsafePerformIO (newIORef defaultHandler)
+
+defaultHandler :: ThreadId -> IO ()
+defaultHandler _ = pure ()
+
+foreign import ccall "setAllocLimitKill" setAllocLimitKill :: CBool -> CBool -> IO ()
+
+runAllocationLimitHandler :: ThreadId# -> IO ()
+runAllocationLimitHandler tid = do
+ hook <- getAllocationLimitHandler
+ hook $ ThreadId tid
+
+getAllocationLimitHandler :: IO (ThreadId -> IO ())
+getAllocationLimitHandler = readIORef allocationLimitHandler
+
+data AllocationLimitKillBehaviour =
+ KillOnAllocationLimit
+ -- ^ Throw a @AllocationLimitExceeded@ async exception to the thread when the
+ -- allocation limit is exceeded.
+ | DontKillOnAllocationLimit
+ -- ^ Do not throw an exception when the allocation limit is exceeded.
+
+-- | Define the behaviour for handling allocation limits.
+-- The default behaviour is to throw an @AllocationLimitExceeded@ async exception to the thread.
+-- This can be overriden using @AllocationLimitKillBehaviour@.
+--
+-- We can set a user-specified handler, which can be run in addition to
+-- or in place of the exception.
+-- This allows for instance logging on the allocation limit being exceeded,
+-- or dynamically determining whether to terminate the thread.
+-- The handler is not guaranteed to run before the thread is terminated or restarted.
+--
+-- Note: that if you don't terminate the thread, then the allocation limit gets
+-- removed.
+-- If you wish to keep the allocation limit you will have to reset it using
+-- @setAllocationCounter@ and @enableAllocationLimit@.
+setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> Maybe (ThreadId -> IO ()) -> IO ()
+setGlobalAllocationLimitHandler killBehaviour mHandler = do
+ shouldRunHandler <- case mHandler of
+ Just hook -> do
+ writeIORef allocationLimitHandler hook
+ pure 1
+ Nothing -> do
+ writeIORef allocationLimitHandler defaultHandler
+ pure 0
+ let shouldKill =
+ case killBehaviour of
+ KillOnAllocationLimit -> 1
+ DontKillOnAllocationLimit -> 0
+ setAllocLimitKill shouldKill shouldRunHandler
+
+-- | Retrieves the allocation counter for the another thread.
+foreign import prim "stg_getOtherThreadAllocationCounterzh" getOtherThreadAllocationCounter#
+ :: ThreadId#
+ -> State# RealWorld
+ -> (# State# RealWorld, Int64# #)
+
+-- | Get the allocation counter for a different thread.
+--
+-- Note: this doesn't take the current nursery chunk into account.
+-- If the thread is running then it may underestimate allocations by the size of a nursery thread.
+getAllocationCounterFor :: ThreadId -> IO Int64
+getAllocationCounterFor (ThreadId t#) = IO $ \s ->
+ case getOtherThreadAllocationCounter# t# s of (# s', i# #) -> (# s', I64# i# #)
+
+-- | Set the allocation counter for a different thread.
+-- This can be combined with 'enableAllocationLimitFor' to enable allocation limits for another thread.
+-- You may wish to do this during a user-specified allocation limit handler.
+--
+-- Note: this doesn't take the current nursery chunk into account.
+-- If the thread is running then it may overestimate allocations by the size of a nursery thread,
+-- and trigger the limit sooner than expected.
+setAllocationCounterFor :: Int64 -> ThreadId -> IO ()
+setAllocationCounterFor (I64# i#) (ThreadId t#) = IO $ \s ->
+ case setOtherThreadAllocationCounter# i# t# s of s' -> (# s', () #)
+
+
+-- | Enable allocation limit processing the thread @t@.
+enableAllocationLimitFor :: ThreadId -> IO ()
+enableAllocationLimitFor (ThreadId t) = do
+ rts_enableThreadAllocationLimit t
+
+-- | Disable allocation limit processing the thread @t@.
+disableAllocationLimitFor :: ThreadId -> IO ()
+disableAllocationLimitFor (ThreadId t) = do
+ rts_disableThreadAllocationLimit t
+
+foreign import ccall unsafe "rts_enableThreadAllocationLimit"
+ rts_enableThreadAllocationLimit :: ThreadId# -> IO ()
+
+foreign import ccall unsafe "rts_disableThreadAllocationLimit"
+ rts_disableThreadAllocationLimit :: ThreadId# -> IO ()
=====================================
rts/Prelude.h
=====================================
@@ -67,6 +67,7 @@ PRELUDE_CLOSURE(ghczminternal_GHCziInternalziEventziWindows_processRemoteComplet
PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure);
PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure);
+PRELUDE_CLOSURE(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure);
PRELUDE_INFO(ghczminternal_GHCziInternalziCString_unpackCStringzh_info);
PRELUDE_INFO(ghczminternal_GHCziInternalziTypes_Czh_con_info);
@@ -102,6 +103,7 @@ PRELUDE_INFO(ghczminternal_GHCziInternalziStable_StablePtr_con_info);
#if defined(mingw32_HOST_OS)
#define processRemoteCompletion_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziEventziWindows_processRemoteCompletion_closure)
#endif
+#define runAllocationLimitHandler_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure)
#define flushStdHandles_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure)
#define runMainIO_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure)
=====================================
rts/PrimOps.cmm
=====================================
@@ -2889,6 +2889,11 @@ stg_getThreadAllocationCounterzh ()
return (StgTSO_alloc_limit(CurrentTSO) - TO_I64(offset));
}
+stg_getOtherThreadAllocationCounterzh ( gcptr t )
+{
+ return (StgTSO_alloc_limit(t));
+}
+
stg_setThreadAllocationCounterzh ( I64 counter )
{
// Allocation in the current block will be subtracted by
@@ -2901,6 +2906,12 @@ stg_setThreadAllocationCounterzh ( I64 counter )
return ();
}
+stg_setOtherThreadAllocationCounterzh ( I64 counter, gcptr t )
+{
+ StgTSO_alloc_limit(t) = counter;
+ return ();
+}
+
#define KEEP_ALIVE_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,c) \
w_ info_ptr, \
=====================================
rts/RtsStartup.c
=====================================
@@ -224,6 +224,7 @@ static void initBuiltinGcRoots(void)
* GHC.Core.Make.mkExceptionId.
*/
getStablePtr((StgPtr)absentSumFieldError_closure);
+ getStablePtr((StgPtr)runAllocationLimitHandler_closure);
}
void
=====================================
rts/RtsSymbols.c
=====================================
@@ -748,6 +748,7 @@ extern char **environ;
SymI_HasProto(rts_enableThreadAllocationLimit) \
SymI_HasProto(rts_disableThreadAllocationLimit) \
SymI_HasProto(rts_setMainThread) \
+ SymI_HasProto(setAllocLimitKill) \
SymI_HasProto(setProgArgv) \
SymI_HasProto(startupHaskell) \
SymI_HasProto(shutdownHaskell) \
@@ -916,7 +917,9 @@ extern char **environ;
SymI_HasDataProto(stg_traceMarkerzh) \
SymI_HasDataProto(stg_traceBinaryEventzh) \
SymI_HasDataProto(stg_getThreadAllocationCounterzh) \
+ SymI_HasDataProto(stg_getOtherThreadAllocationCounterzh) \
SymI_HasDataProto(stg_setThreadAllocationCounterzh) \
+ SymI_HasDataProto(stg_setOtherThreadAllocationCounterzh) \
SymI_HasProto(getMonotonicNSec) \
SymI_HasProto(lockFile) \
SymI_HasProto(unlockFile) \
=====================================
rts/Schedule.c
=====================================
@@ -41,6 +41,7 @@
#include "Threads.h"
#include "Timer.h"
#include "ThreadPaused.h"
+#include "ThreadLabels.h"
#include "Messages.h"
#include "StablePtr.h"
#include "StableName.h"
@@ -94,6 +95,10 @@ StgWord recent_activity = ACTIVITY_YES;
*/
StgWord sched_state = SCHED_RUNNING;
+
+bool allocLimitKill = true;
+bool allocLimitRunHook = false;
+
/*
* This mutex protects most of the global scheduler data in
* the THREADED_RTS runtime.
@@ -1125,19 +1130,36 @@ schedulePostRunThread (Capability *cap, StgTSO *t)
}
}
- //
- // If the current thread's allocation limit has run out, send it
- // the AllocationLimitExceeded exception.
+ // Handle the current thread's allocation limit running out,
if (PK_Int64((W_*)&(t->alloc_limit)) < 0 && (t->flags & TSO_ALLOC_LIMIT)) {
- // Use a throwToSelf rather than a throwToSingleThreaded, because
- // it correctly handles the case where the thread is currently
- // inside mask. Also the thread might be blocked (e.g. on an
- // MVar), and throwToSingleThreaded doesn't unblock it
- // correctly in that case.
- throwToSelf(cap, t, allocationLimitExceeded_closure);
- ASSIGN_Int64((W_*)&(t->alloc_limit),
- (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+ if(allocLimitKill) {
+ // Throw the AllocationLimitExceeded exception.
+ // Use a throwToSelf rather than a throwToSingleThreaded, because
+ // it correctly handles the case where the thread is currently
+ // inside mask. Also the thread might be blocked (e.g. on an
+ // MVar), and throwToSingleThreaded doesn't unblock it
+ // correctly in that case.
+ throwToSelf(cap, t, allocationLimitExceeded_closure);
+ ASSIGN_Int64((W_*)&(t->alloc_limit),
+ (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+ } else {
+ // If we aren't killing the thread, we must disable the limit
+ // otherwise we will immediatelly retrigger it.
+ // User defined handlers should re-enable it if wanted.
+ t->flags = t->flags & ~TSO_ALLOC_LIMIT;
+ }
+
+ if(allocLimitRunHook)
+ {
+ // Create a thread to run the allocation limit handler.
+ StgClosure* c = rts_apply(cap, runAllocationLimitHandler_closure, (StgClosure*)t);
+ StgTSO* hookThread = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, c);
+ setThreadLabel(cap, hookThread, "allocation limit handler thread");
+ // Schedule the handler to be run immediatelly.
+ pushOnRunQueue(cap, hookThread);
+ }
+
}
/* some statistics gathering in the parallel case */
@@ -3342,3 +3364,9 @@ resurrectThreads (StgTSO *threads)
}
}
}
+
+void setAllocLimitKill(bool shouldKill, bool shouldHook)
+{
+ allocLimitKill = shouldKill;
+ allocLimitRunHook = shouldHook;
+}
=====================================
rts/external-symbols.list.in
=====================================
@@ -43,6 +43,7 @@ ghczminternal_GHCziInternalziTypes_Izh_con_info
ghczminternal_GHCziInternalziTypes_Fzh_con_info
ghczminternal_GHCziInternalziTypes_Dzh_con_info
ghczminternal_GHCziInternalziTypes_Wzh_con_info
+ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure
ghczminternal_GHCziInternalziPtr_Ptr_con_info
ghczminternal_GHCziInternalziPtr_FunPtr_con_info
ghczminternal_GHCziInternalziInt_I8zh_con_info
=====================================
rts/include/rts/storage/GC.h
=====================================
@@ -209,6 +209,10 @@ void flushExec(W_ len, AdjustorExecutable exec_addr);
// Used by GC checks in external .cmm code:
extern W_ large_alloc_lim;
+// Should triggering an allocation limit kill the thread
+// and should we run a user-defined hook when it is triggered.
+void setAllocLimitKill(bool, bool);
+
/* -----------------------------------------------------------------------------
Performing Garbage Collection
-------------------------------------------------------------------------- */
=====================================
rts/include/rts/storage/TSO.h
=====================================
@@ -157,9 +157,10 @@ typedef struct StgTSO_ {
/*
* The allocation limit for this thread, which is updated as the
* thread allocates. If the value drops below zero, and
- * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the
- * thread, and give the thread a little more space to handle the
- * exception before we raise the exception again.
+ * TSO_ALLOC_LIMIT is set in flags, then a handler is triggerd.
+ * Either we raise an exception in the thread, and give the thread
+ * a little more space to handle the exception before we raise the
+ * exception again; or we run a user defined handler.
*
* This is an integer, because we might update it in a place where
* it isn't convenient to raise the exception, so we want it to
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -604,7 +604,9 @@ RTS_FUN_DECL(stg_traceEventzh);
RTS_FUN_DECL(stg_traceBinaryEventzh);
RTS_FUN_DECL(stg_traceMarkerzh);
RTS_FUN_DECL(stg_getThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_getOtherThreadAllocationCounterzh);
RTS_FUN_DECL(stg_setThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_setOtherThreadAllocationCounterzh);
RTS_FUN_DECL(stg_castWord64ToDoublezh);
RTS_FUN_DECL(stg_castDoubleToWord64zh);
=====================================
testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
=====================================
@@ -13,13 +13,13 @@ Building library 'q' instantiated with
for bkpcabal08-0.1.0.0...
[2 of 4] Compiling B[sig] ( q/B.hsig, nothing )
[3 of 4] Compiling M ( q/M.hs, nothing ) [A changed]
-[4 of 4] Instantiating bkpcabal08-0.1.0.0-CoQJNXLfoYQ4TyvApzFHv-p
+[4 of 4] Instantiating bkpcabal08-0.1.0.0-LjROTJ30vjpHLvYNUnY1dD-p
Preprocessing library 'q' for bkpcabal08-0.1.0.0...
Building library 'q' instantiated with
- A = bkpcabal08-0.1.0.0-5HJrxUERN7CD204UZeT4Ws-impl:A
- B = bkpcabal08-0.1.0.0-5HJrxUERN7CD204UZeT4Ws-impl:B
+ A = bkpcabal08-0.1.0.0-KxkxGUgMJM6Dqo87AQu6V5-impl:A
+ B = bkpcabal08-0.1.0.0-KxkxGUgMJM6Dqo87AQu6V5-impl:B
for bkpcabal08-0.1.0.0...
-[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-1DQJ9DKc4h59P07qcb0kBc-q+J5mAfRWG9IgLmFQVftCb8t/A.o ) [Prelude package changed]
-[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-1DQJ9DKc4h59P07qcb0kBc-q+J5mAfRWG9IgLmFQVftCb8t/B.o ) [Prelude package changed]
+[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-9Cd344YIpXKFRnHN0O8bjR-q+BXOBBkqkS8ELakzWUKHCOx/A.o ) [Prelude package changed]
+[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-9Cd344YIpXKFRnHN0O8bjR-q+BXOBBkqkS8ELakzWUKHCOx/B.o ) [Prelude package changed]
Preprocessing library 'r' for bkpcabal08-0.1.0.0...
Building library 'r' for bkpcabal08-0.1.0.0...
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6693,6 +6694,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6665,6 +6666,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -4610,6 +4610,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6836,6 +6837,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -4607,6 +4607,7 @@ module GHC.Base where
sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -6693,6 +6694,7 @@ module GHC.Exts where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -5873,6 +5873,7 @@ module GHC.PrimOps where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -10916,6 +10917,16 @@ module Prelude.Experimental where
data Unit# = ...
getSolo :: forall a. Solo a -> a
+module System.Mem.Experimental where
+ -- Safety: None
+ type AllocationLimitKillBehaviour :: *
+ data AllocationLimitKillBehaviour = KillOnAllocationLimit | DontKillOnAllocationLimit
+ disableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO GHC.Internal.Int.Int64
+ setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()) -> GHC.Internal.Types.IO ()
+
-- Instances:
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
=====================================
@@ -5876,6 +5876,7 @@ module GHC.PrimOps where
seq# :: forall a s. a -> State# s -> (# State# s, a #)
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shiftL# :: Word# -> Int# -> Word#
shiftRL# :: Word# -> Int# -> Word#
@@ -10919,6 +10920,16 @@ module Prelude.Experimental where
data Unit# = ...
getSolo :: forall a. Solo a -> a
+module System.Mem.Experimental where
+ -- Safety: None
+ type AllocationLimitKillBehaviour :: *
+ data AllocationLimitKillBehaviour = KillOnAllocationLimit | DontKillOnAllocationLimit
+ disableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO GHC.Internal.Int.Int64
+ setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()
+ setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Internal.Types.IO ()) -> GHC.Internal.Types.IO ()
+
-- Instances:
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
=====================================
testsuite/tests/interface-stability/ghc-prim-exports.stdout
=====================================
@@ -2505,6 +2505,7 @@ module GHC.Prim where
seq :: forall {r :: GHC.Internal.Types.RuntimeRep} a (b :: TYPE r). a -> b -> b
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shrinkMutableByteArray# :: forall d. MutableByteArray# d -> Int# -> State# d -> State# d
shrinkSmallMutableArray# :: forall {l :: GHC.Internal.Types.Levity} d (a :: TYPE (GHC.Internal.Types.BoxedRep l)). SmallMutableArray# d a -> Int# -> State# d -> State# d
@@ -3489,6 +3490,7 @@ module GHC.PrimopWrappers where
retry# :: forall a_levpoly. GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, a_levpoly #)
setAddrRange# :: GHC.Internal.Prim.Addr# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
+ setOtherThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.ThreadId# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
shrinkMutableByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
shrinkSmallMutableArray# :: forall s a_levpoly. GHC.Internal.Prim.SmallMutableArray# s a_levpoly -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
=====================================
testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
=====================================
@@ -2505,6 +2505,7 @@ module GHC.Prim where
seq :: forall {r :: GHC.Internal.Types.RuntimeRep} a (b :: TYPE r). a -> b -> b
setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+ setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
shrinkMutableByteArray# :: forall d. MutableByteArray# d -> Int# -> State# d -> State# d
shrinkSmallMutableArray# :: forall {l :: GHC.Internal.Types.Levity} d (a :: TYPE (GHC.Internal.Types.BoxedRep l)). SmallMutableArray# d a -> Int# -> State# d -> State# d
@@ -3492,6 +3493,7 @@ module GHC.PrimopWrappers where
retry# :: forall a_levpoly. GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, a_levpoly #)
setAddrRange# :: GHC.Internal.Prim.Addr# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
+ setOtherThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.ThreadId# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
setThreadAllocationCounter# :: GHC.Internal.Prim.Int64# -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld -> GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld
shrinkMutableByteArray# :: forall s. GHC.Internal.Prim.MutableByteArray# s -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
shrinkSmallMutableArray# :: forall s a_levpoly. GHC.Internal.Prim.SmallMutableArray# s a_levpoly -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.State# s -> GHC.Internal.Prim.State# s
=====================================
testsuite/tests/rts/T22859.hs
=====================================
@@ -0,0 +1,72 @@
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Control.Exception
+import Control.Exception.Backtrace
+import Control.Concurrent
+import Control.Concurrent.MVar
+import System.Mem
+import System.Mem.Experimental
+import GHC.IO (IO (..))
+import GHC.Exts
+import System.IO
+
+-- | Just do some work and hPutStrLn to stderr to indicate that we are making progress
+worker :: IO ()
+worker = loop [] 2
+ where
+ loop !m !n
+ | n > 30 = hPutStrLn stderr . show $ length m
+ | otherwise = do
+ let x = show n
+ hPutStrLn stderr x
+ -- just to bulk out the allocations
+ IO (\s -> case newByteArray# 900000# s of (# s', arr# #) -> (# s', () #))
+ yield
+ loop (x:m) (n + 1)
+
+main :: IO ()
+main = do
+ hSetBuffering stderr LineBuffering -- necessary for Windows, otherwise our output gets garbled
+ done <- newMVar () -- we use this lock to wait for the worker to finish
+ started <- newEmptyMVar
+ let runWorker = do
+ forkIO . withMVar done $ \_ -> flip onException (hPutStrLn stderr "worker died") $ do
+ hPutStrLn stderr "worker starting"
+ putMVar started ()
+ setAllocationCounter 1_000_000
+ enableAllocationLimit
+ worker
+ hPutStrLn stderr "worker done"
+ takeMVar started
+ readMVar done
+ hFlush stderr
+ threadDelay 1000
+ -- default behaviour:
+ -- kill it after the limit is exceeded
+ hPutStrLn stderr "default behaviour"
+ runWorker
+ hPutStrLn stderr "just log once on the hook being triggered"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 1")
+ runWorker
+ hPutStrLn stderr "just log on the hook being triggered"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tid -> do
+ hPutStrLn stderr "allocation limit triggered 2"
+ -- re-enable the hook
+ setAllocationCounterFor 1_000_000 tid
+ enableAllocationLimitFor tid
+ runWorker
+ hPutStrLn stderr "kill from the hook"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tId -> throwTo tId AllocationLimitExceeded
+ runWorker
+ -- not super helpful, but let's test it anyway
+ hPutStrLn stderr "do nothing"
+ setGlobalAllocationLimitHandler DontKillOnAllocationLimit Nothing
+ runWorker
+ -- this is possible to handle using an exception handler instead.
+ hPutStrLn stderr "kill and log"
+ setGlobalAllocationLimitHandler KillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 3")
+ runWorker
+ threadDelay 1000
+ hPutStrLn stderr "done"
=====================================
testsuite/tests/rts/T22859.stderr
=====================================
@@ -0,0 +1,140 @@
+default behaviour
+worker starting
+2
+3
+worker died
+T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException:
+
+allocation limit exceeded
+just log once on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 1
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+just log on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 2
+4
+5
+allocation limit triggered 2
+6
+7
+allocation limit triggered 2
+8
+9
+allocation limit triggered 2
+10
+11
+allocation limit triggered 2
+12
+13
+allocation limit triggered 2
+14
+15
+allocation limit triggered 2
+16
+17
+allocation limit triggered 2
+18
+19
+allocation limit triggered 2
+20
+21
+allocation limit triggered 2
+22
+23
+allocation limit triggered 2
+24
+25
+allocation limit triggered 2
+26
+27
+allocation limit triggered 2
+28
+29
+allocation limit triggered 2
+30
+29
+worker done
+kill from the hook
+worker starting
+2
+3
+worker died
+T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException:
+
+allocation limit exceeded
+do nothing
+worker starting
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+kill and log
+worker starting
+2
+3
+allocation limit triggered 3
+worker died
+T22859: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.SomeAsyncException:
+
+allocation limit exceeded
+done
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -643,3 +643,8 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru
test('T25560', [req_c_rts, ignore_stderr], compile_and_run, [''])
test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main'])
+test('T22859',
+ [js_skip
+ # Allocation behaviour differs with the wasm backend so we get different output
+ when(arch('wasm32'), skip)],
+ ], compile_and_run, ['-with-rtsopts -A8K'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7211bc5e370ec3a566436b4a7a8fe50…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7211bc5e370ec3a566436b4a7a8fe50…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bump-win32-tarballs] rts: Implement WEAK EXTERNAL undef redirection by target symbol name
by Tamar Christina (＠Phyx) 06 Jul '25
by Tamar Christina (＠Phyx) 06 Jul '25
06 Jul '25
Tamar Christina pushed to branch wip/bump-win32-tarballs at Glasgow Haskell Compiler / GHC
Commits:
e3bfc624 by Tamar Christina at 2025-07-06T12:25:24+01:00
rts: Implement WEAK EXTERNAL undef redirection by target symbol name
- - - - -
1 changed file:
- rts/linker/PEi386.c
Changes:
=====================================
rts/linker/PEi386.c
=====================================
@@ -1168,7 +1168,11 @@ bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f
// way is to load the symbol immediately. We already have all the
// information so might as well
SymbolAddr* sym = lookupSymbolInDLL_PEi386 (symbol, instance, dll, NULL);
- ASSERT(sym);
+
+ // Could be an import descriptor etc, skip if no symbol.
+ if (!sym)
+ return true;
+
// The symbol must have been found, and we can add it to the RTS symbol table
IF_DEBUG(linker, debugBelch("checkAndLoadImportLibrary: resolved symbol %s to %p\n", symbol, sym));
// Because the symbol has been loaded before we actually need it, if a
@@ -1932,6 +1936,27 @@ ocGetNames_PEi386 ( ObjectCode* oc )
}
if(NULL != targetSection)
addr = (SymbolAddr*) ((size_t) targetSection->start + getSymValue(info, targetSym));
+ else
+ {
+ // Do the symbol lookup based on name, this follows Microsoft's weak external's
+ // format 3 specifications. Example header generated:
+ // api-ms-win-crt-stdio-l1-1-0.dll: file format pe-x86-64
+ //
+ // SYMBOL TABLE:
+ // [ 0](sec -1)(fl 0x00)(ty 0)(scl 3) (nx 0) 0x0000000000000000 @comp.id
+ // [ 1](sec -1)(fl 0x00)(ty 0)(scl 3) (nx 0) 0x0000000000000000 @feat.00
+ // [ 2](sec 0)(fl 0x00)(ty 0)(scl 2) (nx 0) 0x0000000000000000 _write
+ // [ 3](sec 0)(fl 0x00)(ty 0)(scl 105) (nx 1) 0x0000000000000000 write
+ // AUX lnno 3 size 0x0 tagndx 2
+ //
+ // https://learn.microsoft.com/en-us/windows/win32/debug/pe-format#auxiliary-f…
+ SymbolName *target_sname = get_sym_name (getSymShortName (info, targetSym), oc);
+ if (target_sname)
+ addr = lookupSymbol_PEi386 (target_sname, oc, &type);
+
+ IF_DEBUG(linker, debugBelch("weak external symbol @ %s => %s resolved to %p\n", \
+ sname, target_sname, addr));
+ }
}
else if ( secNumber == IMAGE_SYM_UNDEFINED && symValue > 0) {
/* This symbol isn't in any section at all, ie, global bss.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3bfc62416dd738bfd1a4464f0a622c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3bfc62416dd738bfd1a4464f0a622c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/haanss/depdir] And the export list for TH.Syntax should obviously include addDependentDirectory now. Duh.
by Hassan Al-Awwadi (＠hassan.awwadi) 06 Jul '25
by Hassan Al-Awwadi (＠hassan.awwadi) 06 Jul '25
06 Jul '25
Hassan Al-Awwadi pushed to branch wip/haanss/depdir at Glasgow Haskell Compiler / GHC
Commits:
fc8e3b58 by Hassan Al-Awwadi at 2025-07-05T23:14:43+02:00
And the export list for TH.Syntax should obviously include addDependentDirectory now. Duh.
- - - - -
1 changed file:
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
Changes:
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -32,6 +32,7 @@ module Language.Haskell.TH.Syntax (
ModName (..),
addCorePlugin,
addDependentFile,
+ addDependentDirectory,
addForeignFile,
addForeignFilePath,
addForeignSource,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc8e3b5898ae04729f63973e6cbb0bd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc8e3b5898ae04729f63973e6cbb0bd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/haanss/depdir] the TH interface has been extended so the interface test should be updated
by Hassan Al-Awwadi (＠hassan.awwadi) 06 Jul '25
by Hassan Al-Awwadi (＠hassan.awwadi) 06 Jul '25
06 Jul '25
Hassan Al-Awwadi pushed to branch wip/haanss/depdir at Glasgow Haskell Compiler / GHC
Commits:
668322d8 by Hassan Al-Awwadi at 2025-07-05T23:13:26+02:00
the TH interface has been extended so the interface test should be updated
- - - - -
1 changed file:
- testsuite/tests/interface-stability/template-haskell-exports.stdout
Changes:
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
@@ -1727,7 +1727,7 @@ module Language.Haskell.TH.Syntax where
qExtsEnabled :: m [Extension]
qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m ()
qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
- {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
+ {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
type Quote :: (* -> *) -> Constraint
class GHC.Internal.Base.Monad m => Quote m where
newName :: GHC.Internal.Base.String -> m Name
@@ -1781,6 +1781,7 @@ module Language.Haskell.TH.Syntax where
type VarStrictType = VarBangType
addCorePlugin :: GHC.Internal.Base.String -> Q ()
addDependentFile :: GHC.Internal.IO.FilePath -> Q ()
+ addDependentDirectory :: GHC.Internal.IO.FilePath -> Q ()
addForeignFile :: ForeignSrcLang -> GHC.Internal.Base.String -> Q ()
addForeignFilePath :: ForeignSrcLang -> GHC.Internal.IO.FilePath -> Q ()
addForeignSource :: ForeignSrcLang -> GHC.Internal.Base.String -> Q ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/668322d8ec1d3cda35fcb5e9bcfb445…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/668322d8ec1d3cda35fcb5e9bcfb445…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T23162-spj] This completes moving dict fundeps to the main loop
by Simon Peyton Jones (＠simonpj) 06 Jul '25
by Simon Peyton Jones (＠simonpj) 06 Jul '25
06 Jul '25
Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC
Commits:
0c5da224 by Simon Peyton Jones at 2025-07-05T17:45:38+01:00
This completes moving dict fundeps to the main loop
- - - - -
4 changed files:
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
Changes:
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -10,7 +10,7 @@ module GHC.Tc.Solver.Dict (
solveCallStack, -- For GHC.Tc.Solver
-- * Functional dependencies
- generateTopFunDeps
+ doTopFunDepImprovement, doLocalFunDepImprovement
) where
import GHC.Prelude
@@ -95,7 +95,7 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
-- Try fundeps /after/ tryInstances:
-- see (DFL2) in Note [Do fundeps last]
- ; doLocalFunDepImprovement dict_ct
+-- ; doLocalFunDepImprovement dict_ct
-- doLocalFunDepImprovement does StartAgain if there
-- are any fundeps: see (DFL1) in Note [Do fundeps last]
@@ -1434,7 +1434,7 @@ But in general it's a bit painful to figure out the necessary coercion,
so we just take the first approach. Here is a better example. Consider:
class C a b c | a -> b
And:
- [G] d1 : C T Int Char
+ [G] d1 : C T Int Char
[W] d2 : C T beta Int
In this case, it's *not even possible* to solve the wanted immediately.
So we should simply output the functional dependency and add this guy
@@ -1630,16 +1630,23 @@ as the fundeps.
#7875 is a case in point.
-}
-generateTopFunDeps :: InstEnvs -> Cts -> [FunDepEqn (CtLoc, RewriterSet)]
+doTopFunDepImprovement :: Bag DictCt -> TcS (Cts, Bool)
+-- (doFunDeps inst_envs cts)
+-- * Generate the fundeps from interacting the
+-- top-level `inst_envs` with the constraints `cts`
+-- * Do the unifications and return any unsolved constraints
-- See Note [Fundeps with instances, and equality orientation]
-generateTopFunDeps inst_evs cts
- = foldMap do_top cts -- "RAE" `unionBags` interactions
+doTopFunDepImprovement cts
+ = do { inst_envs <- getInstEnvs
+ ; do_dict_fundeps (do_one inst_envs) cts }
where
- do_top :: Ct -> [FunDepEqn (CtLoc, RewriterSet)]
- do_top (CDictCan (DictCt { di_ev = ev, di_cls = cls, di_tys = xis }))
- = assert (not (isGiven ev)) $
- improveFromInstEnv inst_evs mk_ct_loc cls xis
+ do_one :: InstEnvs -> DictCt -> TcS (Cts, Bool)
+ do_one inst_envs (DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
+ = unifyFunDepWanteds ev eqns
where
+ eqns :: [FunDepEqn (CtLoc, RewriterSet)]
+ eqns = improveFromInstEnv inst_envs mk_ct_loc cls xis
+
dict_pred = mkClassPred cls xis
dict_loc = ctEvLoc ev
dict_origin = ctLocOrigin dict_loc
@@ -1655,93 +1662,57 @@ generateTopFunDeps inst_evs cts
new_orig = FunDepOrigin2 dict_pred dict_origin
inst_pred inst_loc
- do_top _other = []
-
-
-doLocalFunDepImprovement :: DictCt -> SolverStage ()
--- Add wanted constraints from type-class functional dependencies.
-doLocalFunDepImprovement dict_ct@(DictCt { di_ev = work_ev, di_cls = cls })
- = Stage $
- do { inerts <- getInertCans
- ; imp <- foldlM add_fds False (findDictsByClass (inert_dicts inerts) cls)
- ; if imp then startAgainWith (CDictCan dict_ct)
- else continueWith () }
+doLocalFunDepImprovement :: Bag DictCt -> TcS (Cts,Bool)
+-- Add wanted constraints from type-class functional dependencies
+-- against Givens
+doLocalFunDepImprovement cts
+ = do { inerts <- getInertCans -- The inert_dicts are all Givens
+ ; do_dict_fundeps (do_one (inert_dicts inerts)) cts }
where
- work_pred = ctEvPred work_ev
- work_loc = ctEvLoc work_ev
-
- add_fds :: Bool -> DictCt -> TcS Bool
- add_fds so_far (DictCt { di_ev = inert_ev })
- | isGiven work_ev && isGiven inert_ev
- -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps]
- = return so_far
- | otherwise
- = do { traceTcS "doLocalFunDepImprovement" (vcat
- [ ppr work_ev
- , pprCtLoc work_loc, ppr (isGivenLoc work_loc)
- , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc)
- , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ])
-
- ; (new_eqs, unifs)
- <- unifyFunDepWanteds work_ev $
- improveFromAnother (derived_loc, inert_rewriters)
- inert_pred work_pred
-
- -- Emit the deferred constraints
- -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality
- --
- -- All the constraints in `cts` share the same rewriter set so,
- -- rather than looking at it one by one, we pass it to
- -- extendWorkListChildEqs; just a small optimisation.
- ; unless (isEmptyBag cts) $
- updWorkListTcS (extendWorkListChildEqs ev new_eqs)
-
- ; return (so_far || unifs)
- }
+ do_one givens (DictCt { di_cls = cls, di_ev = wanted_ev })
+ = do_dict_fundeps do_one_given (findDictsByClass givens cls)
where
- inert_pred = ctEvPred inert_ev
- inert_loc = ctEvLoc inert_ev
- inert_rewriters = ctEvRewriters inert_ev
- derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth`
- ctl_depth inert_loc
- , ctl_origin = FunDepOrigin1 work_pred
- (ctLocOrigin work_loc)
- (ctLocSpan work_loc)
- inert_pred
- (ctLocOrigin inert_loc)
- (ctLocSpan inert_loc) }
-
-doTopFunDepImprovement :: DictCt -> SolverStage ()
--- Try to functional-dependency improvement between the constraint
--- and the top-level instance declarations
--- See Note [Fundeps with instances, and equality orientation]
--- See also Note [Weird fundeps]
-doTopFunDepImprovement dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
- | isGiven ev -- No improvement for Givens
- = Stage $ continueWith ()
- | otherwise
- = Stage $
- do { traceTcS "try_fundeps" (ppr dict_ct)
- ; instEnvs <- getInstEnvs
- ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis
- ; imp <- emitFunDepWanteds ev fundep_eqns
- ; if imp then startAgainWith (CDictCan dict_ct)
- else continueWith () }
+ wanted_pred = ctEvPred wanted_ev
+ wanted_loc = ctEvLoc wanted_ev
+
+ do_one_given :: DictCt -> TcS (Cts,Bool)
+ do_one_given (DictCt { di_ev = given_ev })
+ = do { traceTcS "doLocalFunDepImprovement" $
+ vcat [ ppr wanted_ev
+ , pprCtLoc wanted_loc, ppr (isGivenLoc wanted_loc)
+ , pprCtLoc given_loc, ppr (isGivenLoc given_loc)
+ , pprCtLoc deriv_loc, ppr (isGivenLoc deriv_loc) ]
+
+ ; unifyFunDepWanteds wanted_ev $
+ improveFromAnother (deriv_loc, given_rewriters)
+ given_pred wanted_pred }
+ where
+ given_pred = ctEvPred given_ev
+ given_loc = ctEvLoc given_ev
+ given_rewriters = ctEvRewriters given_ev
+ deriv_loc = wanted_loc { ctl_depth = deriv_depth
+ , ctl_origin = deriv_origin }
+ deriv_depth = ctl_depth wanted_loc `maxSubGoalDepth`
+ ctl_depth given_loc
+ deriv_origin = FunDepOrigin1 wanted_pred
+ (ctLocOrigin wanted_loc)
+ (ctLocSpan wanted_loc)
+ given_pred
+ (ctLocOrigin given_loc)
+ (ctLocSpan given_loc)
+
+do_dict_fundeps :: (DictCt -> TcS (Cts,Bool)) -> Bag DictCt -> TcS (Cts,Bool)
+do_dict_fundeps do_dict_fundep cts
+ = foldr do_one (return (emptyBag, False)) cts
where
- dict_pred = mkClassPred cls xis
- dict_loc = ctEvLoc ev
- dict_origin = ctLocOrigin dict_loc
- dict_rewriters = ctEvRewriters ev
-
- mk_ct_loc :: ClsInst -- The instance decl
- -> (CtLoc, RewriterSet)
- mk_ct_loc ispec
- = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin
- inst_pred inst_loc }
- , dict_rewriters )
- where
- inst_pred = mkClassPred cls (is_tys ispec)
- inst_loc = getSrcSpan (is_dfun ispec)
+ do_one :: DictCt -> TcS (Cts,Bool) -> TcS (Cts,Bool)
+ do_one dict_ct do_rest
+ = -- assert (not (isGiven (dictCtEvidence dict_ct)) $
+ do { (cts1, unifs1) <- do_dict_fundep dict_ct
+ ; if isEmptyBag cts1 && not unifs1
+ then do_rest -- Common case
+ else do { (cts2, unifs2) <- do_rest
+ ; return (cts1 `unionBags` cts2, unifs1 || unifs2) } }
{- *********************************************************************
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -118,7 +118,7 @@ solveEquality ev eq_rel ty1 ty2
; solveIrred irred_ct } ;
Right eq_ct -> do { tryInertEqs eq_ct
- ; tryFunDeps eq_rel eq_ct
+ ; tryFunDeps eq_ct
; tryQCsEqCt eq_ct
; simpleStage (updInertEqs eq_ct)
; stopWithStage (eqCtEvidence eq_ct) "Kept inert EqCt" } } }
@@ -3044,8 +3044,8 @@ equality with the template on the left. Delicate, but it works.
-}
--------------------
-tryFunDeps :: EqRel -> EqCt -> SolverStage ()
-tryFunDeps eq_rel work_item@(EqCt { eq_lhs = lhs, eq_ev = ev })
+tryFunDeps :: EqCt -> SolverStage ()
+tryFunDeps work_item@(EqCt { eq_lhs = lhs, eq_ev = ev, eq_eq_rel = eq_rel })
| NomEq <- eq_rel
, TyFamLHS tc args <- lhs
= Stage $
@@ -3264,7 +3264,7 @@ improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs
= do { traceTcS "interactFunEq improvements: " $
vcat [ text "Eqns:" <+> ppr improvement_eqns
, text "Candidates:" <+> ppr funeqs_for_tc ]
- ; emitFunDepWanteds work_ev improvement_eqns }
+ ; unifyAndEmitFunDepWanteds work_ev improvement_eqns }
where
work_loc = ctEvLoc work_ev
work_pred = ctEvPred work_ev
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -105,7 +105,7 @@ module GHC.Tc.Solver.Monad (
-- Unification
wrapUnifierX, wrapUnifierTcS, unifyFunDeps, uPairsTcM, unifyForAllBody,
- unifyFunDepWanteds,
+ unifyFunDepWanteds, unifyAndEmitFunDepWanteds,
-- MetaTyVars
newFlexiTcSTy, instFlexiX,
@@ -2243,6 +2243,23 @@ solverDepthError loc ty
************************************************************************
-}
+unifyAndEmitFunDepWanteds :: CtEvidence -- The work item
+ -> [FunDepEqn (CtLoc, RewriterSet)]
+ -> TcS Bool -- True <=> some unification happened
+unifyAndEmitFunDepWanteds ev fd_eqns
+ = do { (new_eqs, unifs) <- unifyFunDepWanteds ev fd_eqns
+
+ ; -- Emit the deferred constraints
+ -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality
+ --
+ -- All the constraints in `cts` share the same rewriter set so,
+ -- rather than looking at it one by one, we pass it to
+ -- extendWorkListChildEqs; just a small optimisation.
+ ; unless (isEmptyBag new_eqs) $
+ updWorkListTcS (extendWorkListChildEqs ev new_eqs)
+
+ ; return unifs }
+
unifyFunDepWanteds :: CtEvidence -- The work item
-> [FunDepEqn (CtLoc, RewriterSet)]
-> TcS (Cts, Bool) -- True <=> some unification happened
=====================================
compiler/GHC/Tc/Solver/Solve.hs
=====================================
@@ -26,7 +26,6 @@ import GHC.Tc.Types
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.CtLoc( mkGivenLoc )
-import GHC.Tc.Instance.FunDeps ( FunDepEqn(..) )
import GHC.Tc.Solver.InertSet
import GHC.Tc.Solver.Monad
import GHC.Tc.Utils.Monad as TcM
@@ -47,7 +46,6 @@ import GHC.Types.Unique.Set( nonDetStrictFoldUniqSet )
import GHC.Data.Bag
import GHC.Data.Maybe
-import GHC.Data.Pair
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -207,14 +205,21 @@ maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples })
| otherwise
= return Nothing
+ dicts :: Bag DictCt
+ dicts = mapMaybeBag is_dict simples
+ where
+ is_dict (CDictCan d) = Just d
+ is_dict _ = Nothing
+
try_fundeps :: TcS (Maybe NextAction)
try_fundeps
- = do { inst_envs <- getInstEnvs
- ; let fundep_eqns = generateTopFunDeps inst_envs simples
- ; (new_eqs, unif_happened) <- unifyFunDepWanteds fundep_eqns
- ; if null new_eqs && not unif_happened
+ = do { (new_eqs1, unifs1) <- doTopFunDepImprovement dicts
+ ; (new_eqs2, unifs2) <- doLocalFunDepImprovement dicts
+ ; let new_eqs = new_eqs1 `unionBags` new_eqs2
+ unifs = unifs1 || unifs2
+ ; if null new_eqs && not unifs
then return Nothing
- else return (Just (NA_TryAgain (wc `addSimples` new_eqs) unif_happened)) }
+ else return (Just (NA_TryAgain (wc `addSimples` new_eqs) unifs)) }
{- Note [Superclass iteration]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c5da2245dd48e9f3dacefebeac4a14…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c5da2245dd48e9f3dacefebeac4a14…
You're receiving this email because of your account on gitlab.haskell.org.
1
0