- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Add necessary flag for js linking
by Marge Bot (＠marge-bot) 11 Jun '25

11 Jun '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 448a55aa by maralorn at 2025-06-11T12:05:50-04:00 Add necessary flag for js linking - - - - - 459e8a42 by maralorn at 2025-06-11T12:05:50-04:00 Don’t use additional linker flags to detect presence of -fno-pie in configure.ac This mirrors the behavior of ghc-toolchain - - - - - 4c4c33d1 by Krzysztof Gogolewski at 2025-06-11T12:05:51-04:00 Fix EPT enforcement when mixing unboxed tuples and non-tuples The code was assuming that an alternative cannot be returning a normal datacon and an unboxed tuple at the same time. However, as seen in #26107, this can happen when using a GADT to refine the representation type. The solution is just to conservatively return TagDunno. - - - - - 6 changed files: - compiler/GHC/Stg/EnforceEpt/Types.hs - m4/fp_gcc_supports_no_pie.m4 - m4/fptools_set_c_ld_flags.m4 - + testsuite/tests/rep-poly/T26107.hs - testsuite/tests/rep-poly/all.T - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs Changes: ===================================== compiler/GHC/Stg/EnforceEpt/Types.hs ===================================== @@ -39,8 +39,8 @@ type InferStgAlt = GenStgAlt 'InferTaggedBinders combineAltInfo :: TagInfo -> TagInfo -> TagInfo combineAltInfo TagDunno _ = TagDunno combineAltInfo _ TagDunno = TagDunno -combineAltInfo (TagTuple {}) TagProper = panic "Combining unboxed tuple with non-tuple result" -combineAltInfo TagProper (TagTuple {}) = panic "Combining unboxed tuple with non-tuple result" +combineAltInfo (TagTuple {}) TagProper = TagDunno -- This can happen with rep-polymorphic result, see #26107 +combineAltInfo TagProper (TagTuple {}) = TagDunno -- This can happen with rep-polymorphic result, see #26107 combineAltInfo TagProper TagProper = TagProper combineAltInfo (TagTuple is1) (TagTuple is2) = TagTuple (zipWithEqual combineAltInfo is1 is2) combineAltInfo (TagTagged) ti = ti ===================================== m4/fp_gcc_supports_no_pie.m4 ===================================== @@ -7,9 +7,9 @@ AC_DEFUN([FP_GCC_SUPPORTS_NO_PIE], AC_REQUIRE([AC_PROG_CC]) AC_MSG_CHECKING([whether CC supports -no-pie]) echo 'int main() { return 0; }' > conftest.c - "$CC" $CONF_GCC_CC_OPTS_STAGE2 -c conftest.c + "$CC" -c conftest.c # Some GCC versions only warn when passed an unrecognized flag. - if "$CC" $CONF_GCC_LINKER_OPTS_STAGE2 -no-pie -Werror conftest.o -o conftest > conftest.txt 2>&1 && ! grep -i unrecognized conftest.txt > /dev/null 2>&1; then + if "$CC" -no-pie -Werror conftest.o -o conftest > conftest.txt 2>&1 && ! grep -i unrecognized conftest.txt > /dev/null 2>&1; then CONF_GCC_SUPPORTS_NO_PIE=YES AC_MSG_RESULT([yes]) else ===================================== m4/fptools_set_c_ld_flags.m4 ===================================== @@ -109,6 +109,9 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], $2="$$2 -mcmodel=medium" ;; + javascript*) + $3="$$3 -sEXPORTED_RUNTIME_METHODS=HEAP8,HEAPU8" + esac AC_MSG_RESULT([done]) ===================================== testsuite/tests/rep-poly/T26107.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs, UnboxedTuples #-} +module T26107 where + +import Data.Kind +import GHC.Exts + +type T :: TYPE rep -> Type +data T a where + A :: T Bool + B :: T (# #) + +f :: forall rep (a :: TYPE rep). T a -> a +f A = True +f B = (# #) ===================================== testsuite/tests/rep-poly/all.T ===================================== @@ -41,6 +41,7 @@ test('T23883a', normal, compile_fail, ['']) test('T23883b', normal, compile_fail, ['']) test('T23883c', normal, compile_fail, ['']) test('T23903', normal, compile_fail, ['']) +test('T26107', normal, compile, ['-O']) test('EtaExpandDataCon', normal, compile, ['-O']) test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags']) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs ===================================== @@ -324,6 +324,10 @@ addPlatformDepLinkFlags archOs cc ccLink0 = do ArchOS ArchPPC OSAIX -> -- We need `-D_THREAD_SAFE` to unlock the thread-local `errno`. return $ ccLink2 & over _prgFlags (++["-D_THREAD_SAFE","-Wl,-bnotextro"]) + ArchOS ArchJavaScript OSGhcjs -> + -- Since https://github.com/emscripten-core/emscripten/blob/main/ChangeLog.md#407---… + -- the emcc linker does not export the HEAP8 memory view which is used by the js RTS by default anymore. + return $ ccLink2 & _prgFlags %++ "-sEXPORTED_RUNTIME_METHODS=HEAP8,HEAPU8" _ -> return ccLink2 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a0a015f0d3ac08bfbd6e16dabc65c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a0a015f0d3ac08bfbd6e16dabc65c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109] wibbles
by Simon Peyton Jones (＠simonpj) 11 Jun '25

11 Jun '25

Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC Commits: b02d4987 by Simon Peyton Jones at 2025-06-11T16:56:18+01:00 wibbles - - - - - 3 changed files: - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Unfold/Make.hs - compiler/GHC/HsToCore/Binds.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1900,12 +1900,15 @@ Suppose we have a function with a complicated type: and suppose it is called at: - f 7 @T1 @T2 @T3 dEqT1 ($dfShow dShowT2) t3 + f @T1 @T2 @T3 7 dEqT1 ($dfShow dShowT2) t3 This call is described as a 'CallInfo' whose 'ci_key' is: - [ SpecType T1, SpecType T2, UnspecType, UnspecArg, SpecDict dEqT1 - , SpecDict ($dfShow dShowT2), UnspecArg ] + [ SpecType T1, SpecType T2, UnspecType + , UnspecArg + , SpecDict dEqT1 + , SpecDict ($dfShow dShowT2) + , UnspecArg ] Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'? Because we must specialise the function on type variables that appear ===================================== compiler/GHC/Core/Unfold/Make.hs ===================================== @@ -197,6 +197,9 @@ specUnfolding opts spec_bndrs spec_app rule_lhs_args spec_app (mkLams old_bndrs arg) -- The beta-redexes created by spec_app will be -- simplified away by simplOptExpr + -- ToDo: this is VERY DELICATE for type args. We make + -- (\@a @b x y. TYPE ty) ty1 ty2 d1 d2 + -- and rely on it simplifyign to ty[ty1/a, ty2/b] specUnfolding opts spec_bndrs spec_app rule_lhs_args (CoreUnfolding { uf_src = src, uf_tmpl = tmpl ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -1113,7 +1113,9 @@ dsSpec_help poly_nm poly_id poly_rhs inl bndrs ds_call spec_bndrs = filterOut (`elemVarSet` const_bndrs) rule_bndrs mk_spec_body fn_body = mkLets spec_const_binds $ - mkCoreApps fn_body rule_lhs_args + mkApps fn_body rule_lhs_args + -- ToDo: not mkCoreApps! That uses exprType on fun which + -- fails in specUnfolding, sigh ; tracePm "dsSpec(new route)" $ vcat [ text "poly_id" <+> ppr poly_id View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b02d4987d3ab1ce4816f72055f09978… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b02d4987d3ab1ce4816f72055f09978… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/bump-emscripten
by maralorn (＠maralorn) 11 Jun '25

11 Jun '25

maralorn pushed new branch wip/bump-emscripten at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/bump-emscripten You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Fix various failures to -fprint-unicode-syntax
by Marge Bot (＠marge-bot) 11 Jun '25

11 Jun '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: e2467dbd by Ryan Hendrickson at 2025-06-09T13:07:05-04:00 Fix various failures to -fprint-unicode-syntax - - - - - b4e3515f by meooow25 at 2025-06-11T05:22:03-04:00 Bump containers submodule to 0.8 Also * Allow containers-0.8 for in-tree packages * Bump some submodules so that they allow containers-0.8. These are not at any particular versions. * Remove unused deps containers and split from ucd2haskell * Fix tests affected by the new containers and hpc-bin - - - - - 9fe60c79 by maralorn at 2025-06-11T05:22:07-04:00 Add necessary flag for js linking - - - - - 6a0a015f by maralorn at 2025-06-11T05:22:07-04:00 Don’t use additional linker flags to detect presence of -fno-pie in configure.ac This mirrors the behavior of ghc-toolchain - - - - - 36 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/Parser/PostProcess.hs - compiler/ghc.cabal.in - ghc/ghc-bin.cabal.in - hadrian/hadrian.cabal - libraries/containers - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-heap/ghc-heap.cabal.in - libraries/ghc-internal/tools/ucd2haskell/ucd2haskell.cabal - libraries/ghci/ghci.cabal.in - libraries/haskeline - libraries/hpc - m4/fp_gcc_supports_no_pie.m4 - m4/fptools_set_c_ld_flags.m4 - testsuite/tests/ghci/scripts/T12550.stdout - testsuite/tests/ghci/scripts/T8959b.stderr - testsuite/tests/ghci/scripts/all.T - + testsuite/tests/ghci/scripts/print-unicode-syntax.script - + testsuite/tests/ghci/scripts/print-unicode-syntax.stderr - + testsuite/tests/ghci/scripts/print-unicode-syntax.stdout - testsuite/tests/ghci/should_run/T11825.stdout - testsuite/tests/hpc/fork/hpc_fork.stdout - testsuite/tests/hpc/function/tough.stdout - testsuite/tests/hpc/function2/tough2.stdout - testsuite/tests/hpc/simple/hpc001.stdout - testsuite/tests/partial-sigs/should_fail/T10999.stderr - testsuite/tests/rebindable/DoRestrictedM.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs - utils/haddock/haddock-library/haddock-library.cabal - utils/hpc - utils/hsc2hs - utils/iserv/iserv.cabal.in The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/70cdcb7bd5704e01fb5e254490da7c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/70cdcb7bd5704e01fb5e254490da7c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/libffi-3.5.0] 3 commits: Hadrian: Add option to generate .hie files for stage1 libraries
by Cheng Shao (＠TerrorJack) 11 Jun '25

11 Jun '25

Cheng Shao pushed to branch wip/libffi-3.5.0 at Glasgow Haskell Compiler / GHC Commits: 35826d8b by Matthew Pickering at 2025-06-08T22:00:41+01:00 Hadrian: Add option to generate .hie files for stage1 libraries The +hie_files flavour transformer can be enabled to produce hie files for stage1 libraries. The hie files are produced in the "extra-compilation-artifacts" folder and copied into the resulting bindist. At the moment the hie files are not produced for the release flavour, they add about 170M to the final bindist. Towards #16901 - - - - - e2467dbd by Ryan Hendrickson at 2025-06-09T13:07:05-04:00 Fix various failures to -fprint-unicode-syntax - - - - - 4ebbaf16 by Cheng Shao at 2025-06-11T03:59:52+00:00 libffi: update to 3.5.1 Bumps libffi submodule. - - - - - 23 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/Parser/PostProcess.hs - hadrian/doc/flavours.md - hadrian/doc/user-settings.md - hadrian/src/Context.hs - hadrian/src/Context/Path.hs - hadrian/src/Flavour.hs - hadrian/src/Flavour/Type.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Flavours/Release.hs - libffi-tarballs - testsuite/tests/ghci/scripts/T12550.stdout - testsuite/tests/ghci/scripts/T8959b.stderr - testsuite/tests/ghci/scripts/all.T - + testsuite/tests/ghci/scripts/print-unicode-syntax.script - + testsuite/tests/ghci/scripts/print-unicode-syntax.stderr - + testsuite/tests/ghci/scripts/print-unicode-syntax.stdout - testsuite/tests/ghci/should_run/T11825.stdout Changes: ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -627,9 +627,9 @@ instance (OutputableBndrId l, OutputableBndrId r) GhcTc -> ppr v ppr_rhs = case dir of - Unidirectional -> ppr_simple (text "<-") + Unidirectional -> ppr_simple larrow ImplicitBidirectional -> ppr_simple equals - ExplicitBidirectional mg -> ppr_simple (text "<-") <+> text "where" $$ + ExplicitBidirectional mg -> ppr_simple larrow <+> text "where" $$ (nest 2 $ pprFunBind mg) pprTicks :: SDoc -> SDoc -> SDoc ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -699,7 +699,7 @@ instance OutputableBndrId p TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr pp_inj = case mb_inj of Just (L _ (InjectivityAnn _ lhs rhs)) -> - hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] + hsep [ vbar, ppr lhs, arrow, hsep (map ppr rhs) ] Nothing -> empty (pp_where, pp_eqns) = case info of ClosedTypeFamily mb_eqns -> @@ -868,7 +868,7 @@ instance OutputableBndrId p instance OutputableBndrId p => Outputable (StandaloneKindSig (GhcPass p)) where ppr (StandaloneKindSig _ v ki) - = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki + = text "type" <+> pprPrefixOcc (unLoc v) <+> dcolon <+> ppr ki pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -956,7 +956,7 @@ ppr_expr (HsIf _ e1 e2 e3) ppr_expr (HsMultiIf _ alts) = hang (text "if") 3 (vcat $ toList $ NE.map ppr_alt alts) where ppr_alt (L _ (GRHS _ guards expr)) = - hang vbar 2 (hang (interpp'SP guards) 2 (text "->" <+> pprDeeper (ppr expr))) + hang vbar 2 (hang (interpp'SP guards) 2 (arrow <+> pprDeeper (ppr expr))) ppr_alt (L _ (XGRHS x)) = ppr x -- special case: let ... in let ... @@ -1029,7 +1029,7 @@ ppr_expr (HsUntypedBracket b q) ppr rnq `ppr_with_pending_tc_splices` ps ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) - = hsep [text "proc", ppr pat, text "->", ppr cmd] + = hsep [text "proc", ppr pat, arrow, ppr cmd] ppr_expr (HsStatic _ e) = hsep [text "static", ppr e] @@ -1844,10 +1844,10 @@ pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) matchSeparator :: HsMatchContext fn -> SDoc matchSeparator FunRhs{} = text "=" -matchSeparator CaseAlt = text "->" -matchSeparator LamAlt{} = text "->" -matchSeparator IfAlt = text "->" -matchSeparator ArrowMatchCtxt{} = text "->" +matchSeparator CaseAlt = arrow +matchSeparator LamAlt{} = arrow +matchSeparator IfAlt = arrow +matchSeparator ArrowMatchCtxt{} = arrow matchSeparator PatBindRhs = text "=" matchSeparator PatBindGuards = text "=" matchSeparator StmtCtxt{} = text "<-" ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -1377,7 +1377,7 @@ pprIfaceDecl ss decl@(IfaceFamily { ifName = tycon pp_inj_cond res inj = case filterByList inj binders of [] -> empty - tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)] + tvs -> hsep [vbar, ppr res, arrow, interppSP (map ifTyConBinderName tvs)] pp_rhs IfaceDataFamilyTyCon = ppShowIface ss (text "data") @@ -1464,7 +1464,7 @@ pprRoles suppress_if tyCon bndrs roles text "type role" <+> tyCon <+> hsep (map ppr froles) pprStandaloneKindSig :: SDoc -> IfaceType -> SDoc -pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> text "::" <+> ppr ty +pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> dcolon <+> ppr ty pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name ===================================== compiler/GHC/Iface/Type.hs ===================================== @@ -1747,7 +1747,7 @@ pprTyTcApp ctxt_prec tc tys = , IA_Arg (IfaceLitTy (IfaceStrTyLit n)) Required (IA_Arg ty Required IA_Nil) <- tys -> maybeParen ctxt_prec funPrec - $ char '?' <> ftext (getLexicalFastString n) <> text "::" <> ppr_ty topPrec ty + $ char '?' <> ftext (getLexicalFastString n) <> dcolon <> ppr_ty topPrec ty | IfaceTupleTyCon arity sort <- ifaceTyConSort info , not debug ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1935,7 +1935,7 @@ instance DisambECP (HsCmd GhcPs) where mkHsLitPV (L l a) = cmdFail l (ppr a) mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a) mkHsWildCardPV l = cmdFail l (text "_") - mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig) + mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> dcolon <+> ppr sig) mkHsExplicitListPV l xs _ = cmdFail l $ brackets (pprWithCommas ppr xs) mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp) ===================================== hadrian/doc/flavours.md ===================================== @@ -334,6 +334,8 @@ The supported transformers are listed below: <td>Disable including self-recompilation information in interface files via <code>-fno-write-if-self-recomp</code>. If you are building a distribution you can enable this flag to produce more deterministic interface files.</td> <td><code>hash_unit_ids</code></td> <td>Include a package hash in the unit id of built packages</td> + <td><code>hie_files</code></td> + <td>Produce hie files for stage1 libraries</td> </tr> </table> ===================================== hadrian/doc/user-settings.md ===================================== @@ -47,7 +47,10 @@ data Flavour = Flavour { -> Bool, -- | Whether to build docs and which ones -- (haddocks, user manual, haddock manual) - ghcDocs :: Action DocTargets } + ghcDocs :: Action DocTargets, + -- | Whether to generate .hie files + ghcHieFiles :: Stage -> Bool + } ``` Hadrian provides several built-in flavours (`default`, `quick`, and a few others; see `hadrian/doc/flavours.md`), which can be activated from the command line, @@ -364,6 +367,13 @@ all of the documentation targets: You can pass several `--docs=...` flags, Hadrian will combine their effects. +### HIE files + +The `ghcHieFiles` field controls whether `.hie` files are generated +for source files built with the stage1 compiler. + +For most flavours `.hie` files wil be generated by default. + ### Split sections You can build all or just a few packages with ===================================== hadrian/src/Context.hs ===================================== @@ -3,7 +3,7 @@ module Context ( Context (..), vanillaContext, stageContext, -- * Expressions - getStage, getPackage, getWay, getBuildPath, getPackageDbLoc, getStagedTarget, + getStage, getPackage, getWay, getBuildPath, getHieBuildPath, getPackageDbLoc, getStagedTarget, -- * Paths contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile, pkgSetupConfigDir, ===================================== hadrian/src/Context/Path.hs ===================================== @@ -42,6 +42,10 @@ buildPath context = buildRoot <&> (-/- buildDir context) getBuildPath :: Expr Context b FilePath getBuildPath = expr . buildPath =<< getContext +-- | The output directory for hie files +getHieBuildPath :: Expr Context b FilePath +getHieBuildPath = (-/- "extra-compilation-artifacts" -/- "hie") <$> getBuildPath + -- | Path to the directory containing haddock timing files, used by -- the haddock perf tests. haddockStatsFilesDir :: Action FilePath ===================================== hadrian/src/Flavour.hs ===================================== @@ -21,6 +21,7 @@ module Flavour , enableHiCore , useNativeBignum , enableTextWithSIMDUTF + , enableHieFiles , omitPragmas , completeSetting @@ -75,6 +76,7 @@ flavourTransformers = M.fromList , "boot_nonmoving_gc" =: enableBootNonmovingGc , "dump_stg" =: enableDumpStg , "hash_unit_ids" =: enableHashUnitIds + , "hie_files" =: enableHieFiles ] where (=:) = (,) @@ -324,6 +326,9 @@ enableTextWithSIMDUTF flavour = flavour { enableHashUnitIds :: Flavour -> Flavour enableHashUnitIds flavour = flavour { hashUnitIds = True } +enableHieFiles :: Flavour -> Flavour +enableHieFiles flavour = flavour { ghcHieFiles = (>= Stage1) } + -- | Build stage2 compiler with -fomit-interface-pragmas to reduce -- recompilation. omitPragmas :: Flavour -> Flavour ===================================== hadrian/src/Flavour/Type.hs ===================================== @@ -51,7 +51,10 @@ data Flavour = Flavour { ghcDocs :: Action DocTargets, -- | Whether to uses hashes or inplace for unit ids - hashUnitIds :: Bool + hashUnitIds :: Bool, + + -- | Whether to generate .hie files + ghcHieFiles :: Stage -> Bool } ===================================== hadrian/src/Settings/Builders/Ghc.hs ===================================== @@ -35,6 +35,9 @@ compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do useColor <- shakeColor <$> expr getShakeOptions let hasVanilla = elem vanilla ways hasDynamic = elem dynamic ways + hieFiles <- ghcHieFiles <$> expr flavour + stage <- getStage + hie_path <- getHieBuildPath mconcat [ arg "-Wall" , arg "-Wcompat" , not useColor ? builder (Ghc CompileHs) ? @@ -49,6 +52,10 @@ compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do , ghcLinkArgs , defaultGhcWarningsArgs , builder (Ghc CompileHs) ? arg "-c" + , hieFiles stage ? builder (Ghc CompileHs) ? mconcat + [ arg "-fwrite-ide-info" + , arg "-hiedir", arg hie_path + ] , getInputs , arg "-o", arg =<< getOutput ] ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -283,6 +283,7 @@ defaultFlavour = Flavour , ghcDebugAssertions = const False , ghcSplitSections = False , ghcDocs = cmdDocsArgs + , ghcHieFiles = const False , hashUnitIds = False } -- | Default logic for determining whether to build ===================================== hadrian/src/Settings/Flavours/Release.hs ===================================== @@ -11,4 +11,6 @@ releaseFlavour = $ enableHaddock -- 3. Include unit id hashes $ enableHashUnitIds + -- 4. Include hie files (#16901) + -- $ enableHieFiles $ performanceFlavour { name = "release" } ===================================== libffi-tarballs ===================================== @@ -1 +1 @@ -Subproject commit ac7fa3132d382056837cad297ab4c66418febb69 +Subproject commit 1a5955e69b7b139b066cc31507676afc24959dbd ===================================== testsuite/tests/ghci/scripts/T12550.stdout ===================================== @@ -11,13 +11,13 @@ f ∷ ∀ (a ∷ ★ → ★) b. C a ⇒ a b f ∷ ∀ (a ∷ ★ → ★) b. C a ⇒ a b f ∷ ∀ (a ∷ ★ → ★) b. C a ⇒ a b fmap ∷ ∀ (f ∷ ★ → ★) a b. Functor f ⇒ (a → b) → f a → f b -type Functor :: (★ → ★) → Constraint +type Functor ∷ (★ → ★) → Constraint class Functor f where fmap ∷ ∀ a b. (a → b) → f a → f b ... -- Defined in ‘GHC.Internal.Base’ Functor ∷ (★ → ★) → Constraint -type Functor :: (★ → ★) → Constraint +type Functor ∷ (★ → ★) → Constraint class Functor f where fmap ∷ ∀ a b. (a → b) → f a → f b (<$) ∷ ∀ a b. a → f b → f a @@ -77,7 +77,7 @@ datatypeName (a ∷ k1). Datatype d ⇒ t d f a → [Char] -type Datatype :: ∀ {k}. k → Constraint +type Datatype ∷ ∀ {k}. k → Constraint class Datatype d where datatypeName ∷ ∀ k1 (t ∷ k → (k1 → ★) → k1 → ★) (f ∷ k1 → ★) (a ∷ k1). ===================================== testsuite/tests/ghci/scripts/T8959b.stderr ===================================== @@ -1,4 +1,3 @@ - T8959b.hs:5:7: error: [GHC-83865] • Couldn't match expected type ‘Int → Int’ with actual type ‘()’ • In the expression: () @@ -6,11 +5,12 @@ T8959b.hs:5:7: error: [GHC-83865] T8959b.hs:8:7: error: [GHC-83865] • Couldn't match expected type ‘()’ with actual type ‘t0 → m0 t0’ - • In the expression: proc x -> do return ⤙ x - In an equation for ‘bar’: bar = proc x -> do return ⤙ x + • In the expression: proc x → do return ⤙ x + In an equation for ‘bar’: bar = proc x → do return ⤙ x T8959b.hs:10:7: error: [GHC-83865] • Couldn't match expected type ‘(∀ a. a → a) → a1’ with actual type ‘()’ • In the expression: () ∷ (∀ a. a → a) → a In an equation for ‘baz’: baz = () ∷ (∀ a. a → a) → a + ===================================== testsuite/tests/ghci/scripts/all.T ===================================== @@ -357,6 +357,7 @@ test('T20101', normal, ghci_script, ['T20101.script']) test('T20206', normal, ghci_script, ['T20206.script']) test('T20217', normal, ghci_script, ['T20217.script']) test('T20455', normal, ghci_script, ['T20455.script']) +test('print-unicode-syntax', normal, ghci_script, ['print-unicode-syntax.script']) test('shadow-bindings', normal, ghci_script, ['shadow-bindings.script']) test('T925', normal, ghci_script, ['T925.script']) test('T7388', normal, ghci_script, ['T7388.script']) ===================================== testsuite/tests/ghci/scripts/print-unicode-syntax.script ===================================== @@ -0,0 +1,44 @@ +:set -fprint-unicode-syntax +:set -XArrows -XImplicitParams -XMultiWayIf -XPatternSynonyms -XTemplateHaskell -XTypeFamilyDependencies + +--------------------------------------- +-- Double-colon checks + +import Data.Kind +[d| type Foo :: Type |] + +:{ +foo :: (?imp :: Int) => Int +foo = ?imp +:} +:t foo + +proc x -> (_ -< _) :: _ + +--------------------------------------- +-- Rightwards arrow checks + +[d| type family Foo a = b | b -> c |] + +type family Foo a = b | b -> a +:i Foo + +\_ -> [] 0 + +case () of [] -> 0 + +if | [] -> 0 + +:{ +if | True -> 0 + | True -> 1 +:} + +proc _ -> \_ -> undefined -< 0 + +--------------------------------------- +-- Leftwards arrow checks + +[d| pattern Foo x <- Nothing |] + +[d| pattern Foo x <- Nothing where Foo _ = Nothing |] ===================================== testsuite/tests/ghci/scripts/print-unicode-syntax.stderr ===================================== @@ -0,0 +1,56 @@ +<interactive>:8:10: error: [GHC-44432] + • The standalone kind signature for ‘Foo’ + lacks an accompanying binding + • In the Template Haskell quotation: [d| type Foo ∷ Type |] + +<interactive>:16:11: error: [GHC-03790] + Parse error in command: (_ ⤙ _) ∷ _ + +<interactive>:21:5: error: [GHC-76037] + • Not in scope: type variable ‘c’ + • In the Template Haskell quotation: + [d| type family Foo a = b | b → c |] + +<interactive>:26:7: error: [GHC-83865] + • Couldn't match expected type: t0 → t + with actual type: [a0] + • The function ‘[]’ is applied to one visible argument, + but its type ‘[a]’ has none + In the expression: [] 0 + In the expression: \ _ → [] 0 + • Relevant bindings include + it ∷ p → t (bound at <interactive>:26:1) + +<interactive>:28:12: error: [GHC-83865] + • Couldn't match expected type ‘()’ with actual type ‘[a0]’ + • In the pattern: [] + In a case alternative: [] → 0 + In the expression: case () of [] → 0 + +<interactive>:30:6: error: [GHC-83865] + • Couldn't match expected type ‘Bool’ with actual type ‘[a0]’ + • In the expression: [] + In a stmt of a pattern guard for + a multi-way if alternative: + [] + In the expression: if | [] → 0 + +<interactive>:34:6: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a multi-way if alternative: | True → ... + +<interactive>:37:11: error: [GHC-83865] + • Couldn't match expected type ‘()’ with actual type ‘(a0, b0)’ + • In the expression: proc _ → \ _ → undefined ⤙ 0 + In an equation for ‘it’: it = proc _ → \ _ → undefined ⤙ 0 + +<interactive>:42:17: error: [GHC-76037] + • Not in scope: ‘x’ + • In the Template Haskell quotation: [d| pattern Foo x ← Nothing |] + +<interactive>:44:17: error: [GHC-76037] + • Not in scope: ‘x’ + • In the Template Haskell quotation: + [d| pattern Foo x ← Nothing where + Foo _ = Nothing |] + ===================================== testsuite/tests/ghci/scripts/print-unicode-syntax.stdout ===================================== @@ -0,0 +1,5 @@ +foo ∷ (?imp∷Int) ⇒ Int +type Foo ∷ ★ → ★ +type family Foo a = b | b → a + -- Defined at <interactive>:23:1 +0 ===================================== testsuite/tests/ghci/should_run/T11825.stdout ===================================== @@ -1,4 +1,4 @@ -type X :: ★ → ★ → Constraint +type X ∷ ★ → ★ → Constraint class X a b | a → b where to ∷ a → b {-# MINIMAL to #-} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/845df3cf65036503f762bf861fe6dc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/845df3cf65036503f762bf861fe6dc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fail-with-hascallstack] 10 commits: Make GHCi commands compatible with multiple home units
by Bodigrim (＠Bodigrim) 10 Jun '25

10 Jun '25

Bodigrim pushed to branch wip/fail-with-hascallstack at Glasgow Haskell Compiler / GHC Commits: 5f213bff by fendor at 2025-06-02T09:16:24+02:00 Make GHCi commands compatible with multiple home units === Design We enable all GHCi features that were previously guarded by the `inMulti` option. GHCi supported multiple home units up to a certain degree for quite a while now. The supported feature set was limited, due to a design impasse: One of the home units must be "active", e.g., there must be one `HomeUnit` whose `UnitId` is "active" which is returned when calling ```haskell do hscActiveUnitId <$> getSession ``` This makes sense in a GHC session, since you are always compiling a particular Module, but it makes less intuitive sense in an interactive session. Given an expression to evaluate, we can't easily tell in which "context" the expression should be parsed, typechecked and evaluated. That's why initially, most of GHCi features, except for `:reload`ing were disabled if the GHCi session had more than one `HomeUnitEnv`. We lift this restriction, enabling all features of GHCi for the multiple home unit case. To do this, we fundamentally change the `HomeUnitEnv` graph to be multiple home unit first. Instead of differentiating the case were we have a single home unit and multiple, we now always set up a multiple home unit session that scales seamlessly to an arbitrary amount of home units. We introduce two new `HomeUnitEnv`s that are always added to the `HomeUnitGraph`. They are: The "interactive-ghci", called the `interactiveGhciUnit`, contains the same `DynFlags` that are used by the `InteractiveContext` for interactive evaluation of expressions. This `HomeUnitEnv` is only used on the prompt of GHCi, so we may refer to it as "interactive-prompt" unit. See Note [Relation between the `InteractiveContext` and `interactiveGhciUnitId`] for discussing its role. And the "interactive-session"", called `interactiveSessionUnit` or `interactiveSessionUnitId`, which is used for loading Scripts into GHCi that are not `Target`s of any home unit, via `:load` or `:add`. Both of these "interactive" home units depend on all other `HomeUnitEnv`s that are passed as arguments on the cli. Additionally, the "interactive-ghci" unit depends on `interactive-session`. We always evaluate expressions in the context of the "interactive-ghci" session. Since "interactive-ghci" depends on all home units, we can import any `Module` from the other home units with ease. As we have a clear `HomeUnitGraph` hierarchy, we can set `interactiveGhciUnitId` as the active home unit for the full duration of the GHCi session. In GHCi, we always set `interactiveGhciUnitId` to be the currently active home unit. === Implementation Details Given this design idea, the implementation is relatively straight forward. The core insight is that a `ModuleName` is not sufficient to identify a `Module` in the `HomeUnitGraph`. Thus, large parts of the PR is simply about refactoring usages of `ModuleName` to prefer `Module`, which has a `Unit` attached and is unique over the `HomeUnitGraph`. Consequentially, most usages of `lookupHPT` are likely to be incorrect and have been replaced by `lookupHugByModule` which is keyed by a `Module`. In `GHCi/UI.hs`, we make sure there is only one location where we are actually translating `ModuleName` to a `Module`: * `lookupQualifiedModuleName` If a `ModuleName` is ambiguous, we detect this and report it to the user. To avoid repeated lookups of `ModuleName`s, we store the `Module` in the `InteractiveImport`, which additionally simplifies the interface loading. A subtle detail is that the `DynFlags` of the `InteractiveContext` are now stored both in the `HomeUnitGraph` and in the `InteractiveContext`. In UI.hs, there are multiple code paths where we are careful to update the `DynFlags` in both locations. Most importantly in `addToProgramDynFlags`. --- There is one metric increase in this commit: ------------------------- Metric Increase: T4029 ------------------------- It is an increase from 14.4 MB to 16.1 MB (+11.8%) which sounds like a pretty big regression at first. However, we argue this increase is solely caused by using more data structures for managing multiple home units in the GHCi session. In particular, due to the design decision of using three home units, the base memory usage increases... but by how much? A big contributor is the `UnitState`, of which we have three now, which on its own 260 KB per instance. That makes an additional memory usage of 520 KB, already explaining a third of the overall memory usage increase. Then we store more elements in the `HomeUnitGraph`, we have more `HomeUnitEnv` entries, etc... While we didn't chase down each byte, we looked at the memory usage over time for both `-hi` and `-hT` profiles and can say with confidence while the memory usage increased slightly, we did not introduce any space leak, as the graph looks almost identical as the memory usage graph of GHC HEAD. --- Adds testcases for GHCi multiple home units session * Test truly multiple home unit sessions, testing reload logic and code evaluation. * Test that GHCi commands such as `:all-types`, `:browse`, etc., work * Object code reloading for home modules * GHCi debugger multiple home units session - - - - - de603d01 by fendor at 2025-06-02T09:16:24+02:00 Update "loading compiled code" GHCi documentation To use object code in GHCi, the module needs to be compiled for use in GHCi. To do that, users need to compile their modules with: * `-dynamic` * `-this-unit-id interactive-session` Otherwise, the interface files will not match. - - - - - b255a8ca by Vladislav Zavialov at 2025-06-02T16:00:12-04:00 docs: Fix code example for NoListTuplePuns Without the fix, the example produces an error: Test.hs:11:3: error: [GHC-45219] • Data constructor ‘Tuple’ returns type ‘Tuple2 a b’ instead of an instance of its parent type ‘Tuple a’ • In the definition of data constructor ‘Tuple’ In the data type declaration for ‘Tuple’ Fortunately, a one line change makes it compile. - - - - - 6558467c by Ryan Hendrickson at 2025-06-06T05:46:58-04:00 haddock: Parse math even after ordinary characters Fixes a bug where math sections were not recognized if preceded by a character that isn't special (like space or a markup character). - - - - - 265d0024 by ARATA Mizuki at 2025-06-06T05:47:48-04:00 AArch64 NCG: Fix sub-word arithmetic right shift As noted in Note [Signed arithmetic on AArch64], we should zero-extend sub-word values. Fixes #26061 - - - - - 05e9be18 by Simon Hengel at 2025-06-06T05:48:35-04:00 Allow Unicode in "message" and "hints" with -fdiagnostics-as-json (fixes #26075) - - - - - bfa6b70f by ARATA Mizuki at 2025-06-06T05:49:24-04:00 x86 NCG: Fix code generation of bswap64 on i386 Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> Fix #25601 - - - - - 35826d8b by Matthew Pickering at 2025-06-08T22:00:41+01:00 Hadrian: Add option to generate .hie files for stage1 libraries The +hie_files flavour transformer can be enabled to produce hie files for stage1 libraries. The hie files are produced in the "extra-compilation-artifacts" folder and copied into the resulting bindist. At the moment the hie files are not produced for the release flavour, they add about 170M to the final bindist. Towards #16901 - - - - - e2467dbd by Ryan Hendrickson at 2025-06-09T13:07:05-04:00 Fix various failures to -fprint-unicode-syntax - - - - - da08d54f by Andrew Lelechenko at 2025-06-10T21:00:12+01:00 Add HasCallStack to Control.Monad.Fail.fail CLC proposal https://github.com/haskell/core-libraries-committee/issues/327 2% compile-time allocations increase in T3064, likely because `fail` is now marginally more expensive to compile. Metric Increase: T3064 - - - - - 186 changed files: - compiler/GHC.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Name/Ppr.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/Types.hs - docs/users_guide/exts/data_kinds.rst - docs/users_guide/ghci.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - ghc/GHCi/UI/Info.hs - ghc/GHCi/UI/Monad.hs - ghc/Main.hs - hadrian/doc/flavours.md - hadrian/doc/user-settings.md - hadrian/src/Context.hs - hadrian/src/Context/Path.hs - hadrian/src/Flavour.hs - hadrian/src/Flavour/Type.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Flavours/Release.hs - libraries/base/changelog.md - libraries/base/tests/IO/withBinaryFile002.stderr - libraries/base/tests/IO/withFile002.stderr - libraries/base/tests/IO/withFileBlocking002.stderr - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fail.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO.hs-boot - libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs-boot - testsuite/driver/testlib.py - + testsuite/tests/cmm/should_run/T25601.hs - + testsuite/tests/cmm/should_run/T25601.stdout - + testsuite/tests/cmm/should_run/T25601a.cmm - testsuite/tests/cmm/should_run/all.T - + testsuite/tests/codeGen/should_run/T26061.hs - + testsuite/tests/codeGen/should_run/T26061.stdout - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/deSugar/should_run/DsDoExprFailMsg.stderr - testsuite/tests/deSugar/should_run/DsMonadCompFailMsg.stderr - testsuite/tests/driver/T8526/T8526.stdout - testsuite/tests/driver/fat-iface/fat014.stdout - testsuite/tests/driver/json.stderr - testsuite/tests/driver/json_warn.stderr - testsuite/tests/driver/multipleHomeUnits/multiGHCi.stderr - testsuite/tests/ghc-api/T6145.hs - testsuite/tests/ghc-api/annotations-literals/literals.hs - testsuite/tests/ghc-api/annotations-literals/parsed.hs - testsuite/tests/ghc-api/apirecomp001/myghc.hs - testsuite/tests/ghc-api/fixed-nodes/T1.hs - + testsuite/tests/ghci.debugger/scripts/break031/Makefile - + testsuite/tests/ghci.debugger/scripts/break031/a/A.hs - + testsuite/tests/ghci.debugger/scripts/break031/all.T - + testsuite/tests/ghci.debugger/scripts/break031/b/B.hs - + testsuite/tests/ghci.debugger/scripts/break031/break031a.script - + testsuite/tests/ghci.debugger/scripts/break031/break031a.stdout - + testsuite/tests/ghci.debugger/scripts/break031/break031b.script - + testsuite/tests/ghci.debugger/scripts/break031/break031b.stderr - + testsuite/tests/ghci.debugger/scripts/break031/break031b.stdout - + testsuite/tests/ghci.debugger/scripts/break031/unitA - + testsuite/tests/ghci.debugger/scripts/break031/unitB - testsuite/tests/ghci/linking/dyn/T3372.hs - + testsuite/tests/ghci/prog-mhu001/Makefile - + testsuite/tests/ghci/prog-mhu001/all.T - + testsuite/tests/ghci/prog-mhu001/e/E.hs - + testsuite/tests/ghci/prog-mhu001/prog-mhu001a.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001a.stdout - + testsuite/tests/ghci/prog-mhu001/prog-mhu001b.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001b.stdout - + testsuite/tests/ghci/prog-mhu001/prog-mhu001c.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout - + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001d.stdout - + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001e.stdout - + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.script - + testsuite/tests/ghci/prog-mhu001/prog-mhu001f.stdout - + testsuite/tests/ghci/prog-mhu001/unitE - + testsuite/tests/ghci/prog-mhu001/unitE-main-is - + testsuite/tests/ghci/prog-mhu002/Makefile - + testsuite/tests/ghci/prog-mhu002/a/A.hs - + testsuite/tests/ghci/prog-mhu002/all.T - + testsuite/tests/ghci/prog-mhu002/b/B.hs - + testsuite/tests/ghci/prog-mhu002/c/C.hs - + testsuite/tests/ghci/prog-mhu002/d/Main.hs - + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.stderr - + testsuite/tests/ghci/prog-mhu002/prog-mhu002a.stdout - + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.stderr - + testsuite/tests/ghci/prog-mhu002/prog-mhu002b.stdout - + testsuite/tests/ghci/prog-mhu002/prog-mhu002c.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002c.stdout - + testsuite/tests/ghci/prog-mhu002/prog-mhu002d.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002d.stdout - + testsuite/tests/ghci/prog-mhu002/prog-mhu002e.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002e.stdout - + testsuite/tests/ghci/prog-mhu002/prog-mhu002f.script - + testsuite/tests/ghci/prog-mhu002/prog-mhu002f.stdout - + testsuite/tests/ghci/prog-mhu002/unitA - + testsuite/tests/ghci/prog-mhu002/unitB - + testsuite/tests/ghci/prog-mhu002/unitC - + testsuite/tests/ghci/prog-mhu002/unitD - + testsuite/tests/ghci/prog-mhu003/Makefile - + testsuite/tests/ghci/prog-mhu003/a/A.hs - + testsuite/tests/ghci/prog-mhu003/all.T - + testsuite/tests/ghci/prog-mhu003/b/Foo.hs - + testsuite/tests/ghci/prog-mhu003/c/C.hs - + testsuite/tests/ghci/prog-mhu003/d/Foo.hs - + testsuite/tests/ghci/prog-mhu003/prog-mhu003.script - + testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr - + testsuite/tests/ghci/prog-mhu003/prog-mhu003.stdout - + testsuite/tests/ghci/prog-mhu003/unitA - + testsuite/tests/ghci/prog-mhu003/unitB - + testsuite/tests/ghci/prog-mhu003/unitC - + testsuite/tests/ghci/prog-mhu003/unitD - + testsuite/tests/ghci/prog-mhu004/Makefile - + testsuite/tests/ghci/prog-mhu004/a/Foo.hs - + testsuite/tests/ghci/prog-mhu004/all.T - + testsuite/tests/ghci/prog-mhu004/b/Foo.hs - + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.script - + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr - + testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stdout - + testsuite/tests/ghci/prog-mhu004/prog-mhu004b.script - + testsuite/tests/ghci/prog-mhu004/prog-mhu004b.stdout - + testsuite/tests/ghci/prog-mhu004/unitA - + testsuite/tests/ghci/prog-mhu004/unitB - testsuite/tests/ghci/prog010/ghci.prog010.script - testsuite/tests/ghci/prog018/prog018.stdout - + testsuite/tests/ghci/prog020/A.hs - + testsuite/tests/ghci/prog020/B.hs - + testsuite/tests/ghci/prog020/Makefile - + testsuite/tests/ghci/prog020/all.T - + testsuite/tests/ghci/prog020/ghci.prog020.script - + testsuite/tests/ghci/prog020/ghci.prog020.stderr - + testsuite/tests/ghci/prog020/ghci.prog020.stdout - testsuite/tests/ghci/scripts/T12550.stdout - testsuite/tests/ghci/scripts/T13869.stdout - testsuite/tests/ghci/scripts/T13997.stdout - testsuite/tests/ghci/scripts/T17669.stdout - testsuite/tests/ghci/scripts/T18330.stdout - testsuite/tests/ghci/scripts/T1914.stdout - testsuite/tests/ghci/scripts/T20217.stdout - testsuite/tests/ghci/scripts/T20587.stdout - testsuite/tests/ghci/scripts/T21110.stderr - testsuite/tests/ghci/scripts/T6105.stdout - testsuite/tests/ghci/scripts/T8042.stdout - testsuite/tests/ghci/scripts/T8042recomp.stdout - testsuite/tests/ghci/scripts/T8959b.stderr - testsuite/tests/ghci/scripts/all.T - testsuite/tests/ghci/scripts/ghci024.stdout - testsuite/tests/ghci/scripts/ghci024.stdout-mingw32 - testsuite/tests/ghci/scripts/ghci058.script - + testsuite/tests/ghci/scripts/print-unicode-syntax.script - + testsuite/tests/ghci/scripts/print-unicode-syntax.stderr - + testsuite/tests/ghci/scripts/print-unicode-syntax.stdout - testsuite/tests/ghci/should_run/T11825.stdout - testsuite/tests/ghci/should_run/TopEnvIface.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/quasiquotation/T7918.hs - testsuite/tests/th/T15321.stderr - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs - utils/haddock/haddock-library/test/Documentation/Haddock/ParserSpec.hs - utils/haddock/hypsrc-test/ref/src/Quasiquoter.html The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a7f3468895bd84b31210e8ec23f4f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a7f3468895bd84b31210e8ec23f4f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23109] 8 commits: Hadrian: Add option to generate .hie files for stage1 libraries
by Simon Peyton Jones (＠simonpj) 10 Jun '25

10 Jun '25

Simon Peyton Jones pushed to branch wip/T23109 at Glasgow Haskell Compiler / GHC Commits: 35826d8b by Matthew Pickering at 2025-06-08T22:00:41+01:00 Hadrian: Add option to generate .hie files for stage1 libraries The +hie_files flavour transformer can be enabled to produce hie files for stage1 libraries. The hie files are produced in the "extra-compilation-artifacts" folder and copied into the resulting bindist. At the moment the hie files are not produced for the release flavour, they add about 170M to the final bindist. Towards #16901 - - - - - e2467dbd by Ryan Hendrickson at 2025-06-09T13:07:05-04:00 Fix various failures to -fprint-unicode-syntax - - - - - 43dd53c6 by Simon Peyton Jones at 2025-06-10T16:59:31+01:00 Make injecting implicit bindings into its own pass Previously we were injecting "impliicit bindings" (data constructor worker and wrappers etc) - both at the end of CoreTidy, - and at the start of CorePrep This is unpleasant and confusing. This patch puts it it its own pass, addImplicitBinds, which runs between the two. The function `GHC.CoreToStg.AddImplicitBinds.addImplicitBinds` now takes /all/ TyCons, not just the ones for algebraic data types. That change ripples through to - corePrepPgm - doCodeGen - byteCodeGen All take [TyCon] which includes all TyCons - - - - - c6a31618 by Simon Peyton Jones at 2025-06-10T16:59:31+01:00 Implement unary classes The big change is described exhaustively in Note [Unary class magic] in GHC.Core.TyCon Other changes * We never unbox class dictionaries in worker/wrapper. This has been true for some time now, but the logic is now centralised in functions in GHC.Core.Opt.WorkWrap.Utils, namely `canUnboxTyCon`, and `canUnboxArg` See Note [Do not unbox class dictionaries] in GHC.Core.Opt.WorkWrap.Utils. * Refactored the `notWorthFloating` logic in GHc.Core.Opt.SetLevels. I can't remember if I actually changed any behaviour here, but if so it's only in a corner cases. * Fixed a bug in `GHC.Core.TyCon.isEnumerationTyCon`, which was wrongly returning True for (##). * Remove redundant Role argument to `liftCoSubstWithEx`. It was always Representational. * I refactored evidence generation in the constraint solver: * Made GHC.Tc.Types.Evidence contain better abstactions for evidence generation. * I deleted the file `GHC.Tc.Types.EvTerm` and merged its (small) contents elsewhere. It wasn't paying its way. * Made evidence for implicit parameters go via a proper abstraction. Smaller things * Rename `isDataTyCon` to `isBoxedDataTyCon`. * GHC.Core.Corecion.liftCoSubstWithEx was only called with Representational role, so I baked that into the function and removed the argument. * Get rid of `GHC.Core.TyCon.tyConSingleAlgDataCon_maybe` in favour of calling `not isNewTyCon` at the call sites; more explicit. * Refatored `GHC.Core.TyCon.isInjectiveTyCon`; but I don't think I changed its behaviour * Moved `decomposeIPPred` to GHC.Core.Predicate - - - - - 164ac432 by Simon Peyton Jones at 2025-06-10T16:59:31+01:00 Accept GHCi debugger output change @alt-romes says this is fine - - - - - 5cd71bbc by Simon Peyton Jones at 2025-06-10T16:59:31+01:00 Renaming around predicate types .. we were (as it turned out) abstracting over type-class selectors in SPECIALISATION rules! Wibble isEqPred - - - - - 67591230 by Simon Peyton Jones at 2025-06-10T16:59:31+01:00 This increment adds tryTcS to support shortCutSolver * Make short-cut solver invoke the real solver, so that it works for type families. * Use the short-cut solver for quantified constraints too. * Use prepareSpecLHS for the old route too. Leave decomposeRuleLhs for RULES only. - - - - - 1a608495 by Simon Peyton Jones at 2025-06-10T16:59:31+01:00 Comments only - - - - - 125 changed files: - compiler/GHC/Builtin/Types.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/Core/Class.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Unfold/Make.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg.hs - + compiler/GHC/CoreToStg/AddImplicitBinds.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Foreign/Call.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/Solver/Solve.hs - + compiler/GHC/Tc/Solver/Solve.hs-boot - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - − compiler/GHC/Tc/Types/EvTerm.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs - compiler/GHC/Types/TyThing.hs - compiler/GHC/Types/Var.hs - compiler/ghc.cabal.in - hadrian/doc/flavours.md - hadrian/doc/user-settings.md - hadrian/src/Context.hs - hadrian/src/Context/Path.hs - hadrian/src/Flavour.hs - hadrian/src/Flavour/Type.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Flavours/Release.hs - testsuite/tests/core-to-stg/T24124.stderr - testsuite/tests/deSugar/should_compile/T2431.stderr - testsuite/tests/dependent/should_fail/T13135_simple.stderr - testsuite/tests/dmdanal/should_compile/T16029.stdout - testsuite/tests/dmdanal/sigs/T21119.stderr - testsuite/tests/dmdanal/sigs/T21888.stderr - testsuite/tests/ghci.debugger/scripts/break011.stdout - testsuite/tests/ghci.debugger/scripts/break024.stdout - testsuite/tests/ghci/scripts/T12550.stdout - testsuite/tests/ghci/scripts/T8959b.stderr - testsuite/tests/ghci/scripts/all.T - + testsuite/tests/ghci/scripts/print-unicode-syntax.script - + testsuite/tests/ghci/scripts/print-unicode-syntax.stderr - + testsuite/tests/ghci/scripts/print-unicode-syntax.stdout - testsuite/tests/ghci/should_run/T11825.stdout - testsuite/tests/indexed-types/should_compile/T2238.hs - testsuite/tests/numeric/should_compile/T15547.stderr - testsuite/tests/numeric/should_compile/T23907.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/simplCore/should_compile/DataToTagFamilyScrut.stderr - testsuite/tests/simplCore/should_compile/T15205.stderr - testsuite/tests/simplCore/should_compile/T17366.stderr - testsuite/tests/simplCore/should_compile/T17966.stderr - testsuite/tests/simplCore/should_compile/T22309.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr - testsuite/tests/simplCore/should_compile/T23307.stderr - testsuite/tests/simplCore/should_compile/T23307a.stderr - testsuite/tests/simplCore/should_compile/T25389.stderr - testsuite/tests/simplCore/should_compile/T25713.stderr - testsuite/tests/simplCore/should_compile/T7360.stderr - testsuite/tests/simplStg/should_compile/T15226b.stderr - testsuite/tests/tcplugins/CtIdPlugin.hs - testsuite/tests/typecheck/should_compile/Makefile - testsuite/tests/typecheck/should_compile/T12763.stderr - testsuite/tests/typecheck/should_compile/T14774.stdout - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/unboxedsums/unpack_sums_7.stdout - testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs - testsuite/tests/wasm/should_run/control-flow/RunWasm.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eea9a1825f8d9eb39f93be53779bde… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eea9a1825f8d9eb39f93be53779bde… 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) 10 Jun '25

10 Jun '25

Teo Camarasu pushed to branch wip/T22859 at Glasgow Haskell Compiler / GHC Commits: 0c1fd317 by Teo Camarasu at 2025-06-10T16:30:42+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 - - - - - 24 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/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/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 ===================================== @@ -916,7 +916,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/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 ===================================== @@ -10916,6 +10916,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.Types.IO () + enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO () + getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO GHC.Internal.Int.Int64 + setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO () + setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()) -> GHC.Types.IO () + -- Instances: instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’ ===================================== testsuite/tests/rts/T22859.hs ===================================== @@ -0,0 +1,71 @@ +{-# 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 + 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,152 @@ +default behaviour +worker starting +2 +3 +worker died +T22859: allocation limit exceeded +HasCallStack backtrace: + collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception + toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO + throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base + + +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: allocation limit exceeded +HasCallStack backtrace: + collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception + toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO + throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base + + +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: allocation limit exceeded +HasCallStack backtrace: + collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception + toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO + throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base + + +done ===================================== testsuite/tests/rts/all.T ===================================== @@ -643,3 +643,4 @@ 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], compile_and_run, ['-with-rtsopts -A8K']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c1fd3175865ccec423c4446e550c0f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0c1fd3175865ccec423c4446e550c0f… 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) 10 Jun '25

10 Jun '25

Teo Camarasu pushed to branch wip/T22859 at Glasgow Haskell Compiler / GHC Commits: d3d7e58c by Teo Camarasu at 2025-06-10T16:09:47+01:00 Implement user-defined allocation limit handlers Resolves #22859 - - - - - 24 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/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/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,114 @@ +{-# 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. +-- By default we throw a @AllocationLimitExceeded@ async exception to the thread. +-- This can be controlled using @AllocationLimitKillBehaviour@. +-- +-- We can also run a user-specified handler, which can be done 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. +-- 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 ===================================== @@ -916,7 +916,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/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 ===================================== @@ -10916,6 +10916,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.Types.IO () + enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO () + getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO GHC.Internal.Int.Int64 + setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO () + setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()) -> GHC.Types.IO () + -- Instances: instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’ ===================================== testsuite/tests/rts/T22859.hs ===================================== @@ -0,0 +1,71 @@ +{-# 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 + 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,152 @@ +default behaviour +worker starting +2 +3 +worker died +T22859: allocation limit exceeded +HasCallStack backtrace: + collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception + toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO + throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base + + +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: allocation limit exceeded +HasCallStack backtrace: + collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception + toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO + throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base + + +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: allocation limit exceeded +HasCallStack backtrace: + collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception + toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO + throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base + + +done ===================================== testsuite/tests/rts/all.T ===================================== @@ -643,3 +643,4 @@ 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], compile_and_run, ['-with-rtsopts -A8K']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3d7e58c1e689091e0d900b319e3192… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3d7e58c1e689091e0d900b319e3192… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/visible-forall-gadts] Docs update 2
by Vladislav Zavialov (＠int-index) 10 Jun '25

10 Jun '25

Vladislav Zavialov pushed to branch wip/int-index/visible-forall-gadts at Glasgow Haskell Compiler / GHC Commits: 79866e89 by Vladislav Zavialov at 2025-06-10T12:01:53+03:00 Docs update 2 - - - - - 3 changed files: - compiler/Language/Haskell/Syntax/Decls.hs - docs/users_guide/9.14.1-notes.rst - docs/users_guide/exts/required_type_arguments.rst Changes: ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -970,9 +970,10 @@ data ConDecl pass -- The following fields describe the type after the '::' -- See Note [GADT abstract syntax] , con_outer_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass) - -- ^ The outermost type variable binders, be they explicit or - -- implicit. The 'XRec' is used to anchor exact print - -- annotations, AnnForall and AnnDot. + -- ^ The outermost type variable binders, be they explicit or implicit; + -- cf. HsSigType that also stores the outermost sig_bndrs separately + -- from the forall telescopes in sig_body. + -- See Note [Representing type signatures] in Language.Haskell.Syntax.Type , con_inner_bndrs :: [HsForAllTelescope pass] -- ^ The forall telescopes other than the outermost invisible forall. , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) ===================================== docs/users_guide/9.14.1-notes.rst ===================================== @@ -72,6 +72,18 @@ Language * The :extension:`MonadComprehensions` extension now implies :extension:`ParallelListComp` as was originally intended (see `Monad Comprehensions <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/monad_comprehension…>`_). +* In accordance with `GHC Proposal #281 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0281-v…>`_, + section 4.7 "Data constructors", the :extension:`RequiredTypeArguments` + extension now allows visible forall in types of data constructors + (:ghc-ticket:`25127`). The following declaration is now accepted by GHC: + + :: + + data T a where + Typed :: forall a -> a -> T a + + See :ref:`visible-forall-in-gadts` for details. + Compiler ~~~~~~~~ ===================================== docs/users_guide/exts/required_type_arguments.rst ===================================== @@ -428,6 +428,8 @@ The :extension:`RequiredTypeArguments` extension does not add dependent functions, which would be a much bigger step. Rather :extension:`RequiredTypeArguments` just makes it possible for the type arguments of a function to be compulsory. +.. _visible-forall-in-gadts: + Visible forall in GADTs ~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/79866e89b641c9c80892fa9f6c4d2b2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/79866e89b641c9c80892fa9f6c4d2b2… You're receiving this email because of your account on gitlab.haskell.org.

1 0