07 Jul '25
Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC
Commits:
561cb31e by Ben Gamari at 2025-07-03T11:41:56+02:00
Annotate frame
- - - - -
32 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/GHC/Stack/Annotation/Experimental.hs
- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Stack.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- + libraries/ghc-heap/tests/stack-annotation/Makefile
- + libraries/ghc-heap/tests/stack-annotation/all.T
- + libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs
- + libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout
- + libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs
- + libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout
- libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs
- rts/ClosureFlags.c
- rts/LdvProfile.c
- rts/PrimOps.cmm
- rts/Printer.c
- rts/RetainerProfile.c
- rts/TraverseHeap.c
- rts/include/rts/storage/ClosureTypes.h
- rts/include/rts/storage/Closures.h
- rts/js/profiling.js
- rts/sm/Compact.c
- rts/sm/Evac.c
- rts/sm/NonMovingMark.c
- rts/sm/Sanity.c
- rts/sm/Scav.c
- utils/deriveConstants/Main.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/561cb31e29e74aea7159b7ea275987a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/561cb31e29e74aea7159b7ea275987a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
07 Jul '25
Simon Hengel pushed new branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sol/remove-ddump-json
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/sol/pre-processors-errors] Respect `-fdiagnostics-as-json` for error messages from pre-processors
by Simon Hengel (＠sol) 07 Jul '25
by Simon Hengel (＠sol) 07 Jul '25
07 Jul '25
Simon Hengel pushed to branch wip/sol/pre-processors-errors at Glasgow Haskell Compiler / GHC
Commits:
a8fa2945 by Simon Hengel at 2025-07-07T13:22:14+07:00
Respect `-fdiagnostics-as-json` for error messages from pre-processors
(fixes #25480)
- - - - -
3 changed files:
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/SysTools/Process.hs
- ghc/GHCi/UI.hs
Changes:
=====================================
compiler/GHC/Driver/Errors.hs
=====================================
@@ -1,18 +1,34 @@
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Driver.Errors (
- printOrThrowDiagnostics
+ reportError
, printMessages
+ , printOrThrowDiagnostics
, mkDriverPsHeaderMessage
) where
import GHC.Driver.Errors.Types
import GHC.Prelude
+import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.Error
import GHC.Utils.Error
-import GHC.Utils.Outputable (hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext )
+import GHC.Utils.Outputable
import GHC.Utils.Logger
+reportError :: Logger -> SrcSpan -> SDoc -> IO ()
+reportError logger span message = do
+ printMessages logger NoDiagnosticOpts emptyDiagOpts $ singleMessage MsgEnvelope {
+ errMsgSpan = span
+ , errMsgContext = alwaysQualify
+ , errMsgDiagnostic = DiagnosticMessage {
+ diagMessage = mkDecorated [message]
+ , diagReason = ErrorWithoutFlag
+ , diagHints = []
+ }
+ , errMsgSeverity = SevError
+ , errMsgReason = ResolvedDiagnosticReason ErrorWithoutFlag
+ }
+
printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages logger msg_opts opts msgs
= sequence_ [ let style = mkErrStyle name_ppr_ctx
=====================================
compiler/GHC/SysTools/Process.hs
=====================================
@@ -26,6 +26,8 @@ import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Utils.CliOption
+import GHC.Driver.Errors (reportError)
+
import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan )
import GHC.Data.FastString
@@ -286,8 +288,7 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea
BuildMsg msg -> do
logInfo logger $ withPprStyle defaultUserStyle msg
BuildError loc msg -> do
- logMsg logger errorDiagnostic (mkSrcSpan loc loc)
- $ withPprStyle defaultUserStyle msg
+ reportError logger (mkSrcSpan loc loc) msg
parseBuildMessages :: [String] -> [BuildMessage]
parseBuildMessages str = loop str Nothing
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -52,7 +52,7 @@ import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Core.PatSyn
import GHC.Driver.Flags
-import GHC.Driver.Errors
+import GHC.Driver.Errors (printOrThrowDiagnostics)
import GHC.Driver.Errors.Types
import GHC.Driver.Phases
import GHC.Driver.Session as DynFlags
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8fa2945c584d47490f6b37af6c2822…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8fa2945c584d47490f6b37af6c2822…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
07 Jul '25
Simon Hengel pushed new branch wip/sol/pre-processors-errors at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sol/pre-processors-errors
You're receiving this email because of your account on gitlab.haskell.org.
1
0
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) 06 Jul '25
by Simon Peyton Jones (＠simonpj) 06 Jul '25
06 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) 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:
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) 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:
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) 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:
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