[Git][ghc/ghc][wip/js-rts-fixmes] 4 commits: docs: release notes, user guide: add js backend
Josh Meredith (@JoshMeredith)
gitlab at gitlab.haskell.org
Wed Feb 15 13:15:07 UTC 2023
Josh Meredith pushed to branch wip/js-rts-fixmes at Glasgow Haskell Compiler / GHC
Commits:
08c0822c by doyougnu at 2023-02-15T00:16:39-05:00
docs: release notes, user guide: add js backend
Follow up from #21078
- - - - -
79d8fd65 by Bryan Richter at 2023-02-15T00:17:15-05:00
Allow failure in nightly-x86_64-linux-deb10-no_tntc-validate
See #22343
- - - - -
9ca51f9e by Cheng Shao at 2023-02-15T00:17:53-05:00
rts: add the rts_clearMemory function
This patch adds the rts_clearMemory function that does its best to
zero out unused RTS memory for a wasm backend use case. See the
comment above rts_clearMemory() prototype declaration for more
detailed explanation. Closes #22920.
- - - - -
2c61b4f2 by Josh Meredith at 2023-02-15T13:14:44+00:00
Factor JS Rts generation for h$c{_,0,1,2} into h$c{n} and improve name caching
- - - - -
18 changed files:
- .gitlab/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/JS/Make.hs
- compiler/GHC/StgToJS/Closure.hs
- compiler/GHC/StgToJS/DataCon.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- docs/users_guide/9.6.1-notes.rst
- docs/users_guide/codegens.rst
- rts/RtsSymbols.c
- rts/include/RtsAPI.h
- rts/sm/BlockAlloc.c
- rts/sm/BlockAlloc.h
- rts/sm/NonMoving.h
- rts/sm/NonMovingSweep.c
- rts/sm/Storage.c
- rts/sm/Storage.h
- testsuite/tests/ffi/should_run/ffi023_c.c
Changes:
=====================================
.gitlab/gen_ci.hs
=====================================
@@ -713,6 +713,10 @@ modifyJobs = fmap
modifyValidateJobs :: (a -> a) -> JobGroup a -> JobGroup a
modifyValidateJobs f jg = jg { v = f <$> v jg }
+-- | Modify just the nightly jobs in a 'JobGroup'
+modifyNightlyJobs :: (a -> a) -> JobGroup a -> JobGroup a
+modifyNightlyJobs f jg = jg { n = f <$> n jg }
+
-- Generic helpers
addJobRule :: Rule -> Job -> Job
@@ -854,7 +858,9 @@ job_groups =
, fastCI (validateBuilds Amd64 (Linux Debian10) unreg)
, fastCI (validateBuilds Amd64 (Linux Debian10) debug)
, modifyValidateJobs manual tsan_jobs
- , modifyValidateJobs manual (validateBuilds Amd64 (Linux Debian10) noTntc)
+ , -- Nightly allowed to fail: #22343
+ modifyNightlyJobs allowFailure
+ (modifyValidateJobs manual (validateBuilds Amd64 (Linux Debian10) noTntc))
, addValidateRule LLVMBackend (validateBuilds Amd64 (Linux Debian10) llvm)
, disableValidate (standardBuilds Amd64 (Linux Debian11))
=====================================
.gitlab/jobs.yaml
=====================================
@@ -978,7 +978,7 @@
".gitlab/ci.sh clean",
"cat ci_timings"
],
- "allow_failure": false,
+ "allow_failure": true,
"artifacts": {
"expire_in": "8 weeks",
"paths": [
=====================================
compiler/GHC/JS/Make.hs
=====================================
@@ -126,10 +126,6 @@ module GHC.JS.Make
math_cosh, math_sinh, math_tanh, math_expm1, math_log1p, math_fround
-- * Statement helpers
, decl
- -- * Miscellaneous
- -- $misc
- , allocData, allocClsA
- , dataFieldName, dataFieldNames
)
where
@@ -139,13 +135,10 @@ import GHC.JS.Syntax
import Control.Arrow ((***))
-import Data.Array
import qualified Data.Map as M
-import GHC.Utils.Outputable (Outputable (..))
import GHC.Data.FastString
import GHC.Utils.Monad.State.Strict
-import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Types.Unique.Map
@@ -631,43 +624,6 @@ instance Fractional JExpr where
fromRational x = ValExpr (JDouble (realToFrac x))
---------------------------------------------------------------------------------
--- Miscellaneous
---------------------------------------------------------------------------------
--- $misc
--- Everything else,
-
--- | Cache "dXXX" field names
-dataFieldCache :: Array Int FastString
-dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache])
-
-nFieldCache :: Int
-nFieldCache = 16384
-
-dataFieldName :: Int -> FastString
-dataFieldName i
- | i < 1 || i > nFieldCache = panic "dataFieldName" (ppr i)
- | otherwise = dataFieldCache ! i
-
-dataFieldNames :: [FastString]
-dataFieldNames = fmap dataFieldName [1..nFieldCache]
-
-
--- | Cache "h$dXXX" names
-dataCache :: Array Int FastString
-dataCache = listArray (0,1024) (map (mkFastString . ("h$d"++) . show) [(0::Int)..1024])
-
-allocData :: Int -> JExpr
-allocData i = toJExpr (TxtI (dataCache ! i))
-
--- | Cache "h$cXXX" names
-clsCache :: Array Int FastString
-clsCache = listArray (0,1024) (map (mkFastString . ("h$c"++) . show) [(0::Int)..1024])
-
-allocClsA :: Int -> JExpr
-allocClsA i = toJExpr (TxtI (clsCache ! i))
-
-
--------------------------------------------------------------------------------
-- New Identifiers
--------------------------------------------------------------------------------
=====================================
compiler/GHC/StgToJS/Closure.hs
=====================================
@@ -10,6 +10,15 @@ module GHC.StgToJS.Closure
, assignClosure
, CopyCC (..)
, copyClosure
+ , mkClosure
+ -- $names
+ , allocData
+ , allocClsA
+ , dataName
+ , clsName
+ , dataFieldName
+ , varName
+ , jsClosureCount
)
where
@@ -24,6 +33,9 @@ import GHC.StgToJS.Regs (stack,sp)
import GHC.JS.Make
import GHC.JS.Syntax
+import GHC.Types.Unique.Map
+
+import Data.Array
import Data.Monoid
import qualified Data.Bits as Bits
@@ -154,3 +166,78 @@ copyClosure copy_cc t s = BlockStat
] <> case copy_cc of
DontCopyCC -> mempty
CopyCC -> closureCC t |= closureCC s
+
+mkClosure :: JExpr -> [JExpr] -> JExpr -> Maybe JExpr -> Closure
+mkClosure entry fields meta cc = Closure
+ { clEntry = entry
+ , clField1 = x1
+ , clField2 = x2
+ , clMeta = meta
+ , clCC = cc
+ }
+ where
+ x1 = case fields of
+ [] -> null_
+ x:_ -> x
+ x2 = case fields of
+ [] -> null_
+ [_] -> null_
+ [_,x] -> x
+ _:x:xs -> ValExpr . JHash . listToUniqMap $ zip (map dataFieldName [1..]) (x:xs)
+
+
+-------------------------------------------------------------------------------
+-- Name Caches
+-------------------------------------------------------------------------------
+-- $names
+
+-- | Cache "dXXX" field names
+dataFieldCache :: Array Int FastString
+dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache])
+
+-- | Data names are used in the AST, and logging has determined that 255 is the maximum number we see.
+nFieldCache :: Int
+nFieldCache = 255
+
+-- | We use this in the RTS to determine the number of generated closures. These closures use the names
+-- cached here, so we bind them to the same number.
+jsClosureCount :: Int
+jsClosureCount = 24
+
+dataFieldName :: Int -> FastString
+dataFieldName i
+ | i < 0 || i > nFieldCache = mkFastString ('d' : show i)
+ | otherwise = dataFieldCache ! i
+
+-- | Cache "h$dXXX" names
+dataCache :: Array Int FastString
+dataCache = listArray (0,jsClosureCount) (map (mkFastString . ("h$d"++) . show) [(0::Int)..jsClosureCount])
+
+dataName :: Int -> FastString
+dataName i
+ | i < 0 || i > nFieldCache = mkFastString ("h$d" ++ show i)
+ | otherwise = dataCache ! i
+
+allocData :: Int -> JExpr
+allocData i = toJExpr (TxtI (dataName i))
+
+-- | Cache "h$cXXX" names
+clsCache :: Array Int FastString
+clsCache = listArray (0,jsClosureCount) (map (mkFastString . ("h$c"++) . show) [(0::Int)..jsClosureCount])
+
+clsName :: Int -> FastString
+clsName i
+ | i < 0 || i > jsClosureCount = mkFastString ("h$c" ++ show i)
+ | otherwise = clsCache ! i
+
+allocClsA :: Int -> JExpr
+allocClsA i = toJExpr (TxtI (clsName i))
+
+-- | Cache "xXXX" names
+varCache :: Array Int Ident
+varCache = listArray (0,jsClosureCount) (map (TxtI . mkFastString . ('x':) . show) [(0::Int)..jsClosureCount])
+
+varName :: Int -> Ident
+varName i
+ | i < 0 || i > jsClosureCount = TxtI $ mkFastString ('x' : show i)
+ | otherwise = varCache ! i
=====================================
compiler/GHC/StgToJS/DataCon.hs
=====================================
@@ -97,23 +97,11 @@ allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig
-> Maybe JExpr
-> JExpr
allocDynamicE inline_alloc entry free cc
- | inline_alloc || length free > 24 = newClosure $ Closure
- { clEntry = entry
- , clField1 = fillObj1
- , clField2 = fillObj2
- , clMeta = ValExpr (JInt 0)
- , clCC = cc
- }
+ | inline_alloc || length free > jsClosureCount
+ = newClosure $ mkClosure entry free (ValExpr (JInt 0)) cc
| otherwise = ApplExpr allocFun (toJExpr entry : free ++ maybeToList cc)
where
allocFun = allocClsA (length free)
- (fillObj1,fillObj2)
- = case free of
- [] -> (null_, null_)
- [x] -> (x,null_)
- [x,y] -> (x,y)
- (x:xs) -> (x,toJExpr (JHash $ listToUniqMap (zip dataFields xs)))
- dataFields = map (mkFastString . ('d':) . show) [(1::Int)..]
-- | Allocate a dynamic object
allocDynamic :: StgToJSConfig -> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.JS.Make
import GHC.StgToJS.Apply
import GHC.StgToJS.Arg
+import GHC.StgToJS.Closure
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.FFI
import GHC.StgToJS.Heap
@@ -1006,7 +1007,7 @@ allocDynAll haveDecl middle cls = do
]
(ex:es) -> mconcat
[ toJExpr i .^ closureField1_ |= toJExpr ex
- , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip dataFieldNames es))
+ , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip (map dataFieldName [1..]) es))
]
| otherwise = case es of
[] -> mempty
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -81,36 +81,8 @@ resetResultVar r = toJExpr r |= null_
-- JIT can optimize better.
closureConstructors :: StgToJSConfig -> JStat
closureConstructors s = BlockStat
- [ declClsConstr "h$c" ["f"] $ Closure
- { clEntry = var "f"
- , clField1 = null_
- , clField2 = null_
- , clMeta = 0
- , clCC = ccVal
- }
- , declClsConstr "h$c0" ["f"] $ Closure
- { clEntry = var "f"
- , clField1 = null_
- , clField2 = null_
- , clMeta = 0
- , clCC = ccVal
- }
- , declClsConstr "h$c1" ["f", "x1"] $ Closure
- { clEntry = var "f"
- , clField1 = var "x1"
- , clField2 = null_
- , clMeta = 0
- , clCC = ccVal
- }
- , declClsConstr "h$c2" ["f", "x1", "x2"] $ Closure
- { clEntry = var "f"
- , clField1 = var "x1"
- , clField2 = var "x2"
- , clMeta = 0
- , clCC = ccVal
- }
- , mconcat (map mkClosureCon [3..24])
- , mconcat (map mkDataFill [1..24])
+ [ mconcat (map mkClosureCon (Nothing : map Just [0..jsClosureCount]))
+ , mconcat (map mkDataFill [1..jsClosureCount])
]
where
prof = csProf s
@@ -118,19 +90,8 @@ closureConstructors s = BlockStat
-- the cc argument happens to be named just like the cc field...
| prof = ([TxtI closureCC_], Just (var closureCC_))
| otherwise = ([], Nothing)
- addCCArg as = map TxtI as ++ ccArg
addCCArg' as = as ++ ccArg
- declClsConstr i as cl = TxtI i ||= ValExpr (JFunc (addCCArg as)
- ( jVar $ \x ->
- [ checkC
- , x |= newClosure cl
- , notifyAlloc x
- , traceAlloc x
- , returnS x
- ]
- ))
-
traceAlloc x | csTraceRts s = appS "h$traceAlloc" [x]
| otherwise = mempty
@@ -172,29 +133,24 @@ closureConstructors s = BlockStat
| otherwise = mempty
- mkClosureCon :: Int -> JStat
- mkClosureCon n = funName ||= toJExpr fun
+ mkClosureCon :: Maybe Int -> JStat
+ mkClosureCon n0 = funName ||= toJExpr fun
where
- funName = TxtI $ mkFastString ("h$c" ++ show n)
+ n | Just n' <- n0 = n'
+ | Nothing <- n0 = 0
+ funName | Just n' <- n0 = TxtI $ clsName n'
+ | Nothing <- n0 = TxtI $ mkFastString "h$c"
-- args are: f x1 x2 .. xn [cc]
- args = TxtI "f" : addCCArg' (map (TxtI . mkFastString . ('x':) . show) [(1::Int)..n])
+ args = TxtI "f" : addCCArg' (map varName [1..n])
fun = JFunc args funBod
-- x1 goes into closureField1. All the other args are bundled into an
-- object in closureField2: { d1 = x2, d2 = x3, ... }
--
- extra_args = ValExpr . JHash . listToUniqMap $ zip
- (map (mkFastString . ('d':) . show) [(1::Int)..])
- (map (toJExpr . TxtI . mkFastString . ('x':) . show) [2..n])
+ vars = map (toJExpr . varName) [1..n]
funBod = jVar $ \x ->
[ checkC
- , x |= newClosure Closure
- { clEntry = var "f"
- , clField1 = var "x1"
- , clField2 = extra_args
- , clMeta = 0
- , clCC = ccVal
- }
+ , x |= newClosure (mkClosure (var "f") vars 0 ccVal)
, notifyAlloc x
, traceAlloc x
, returnS x
@@ -203,8 +159,8 @@ closureConstructors s = BlockStat
mkDataFill :: Int -> JStat
mkDataFill n = funName ||= toJExpr fun
where
- funName = TxtI $ mkFastString ("h$d" ++ show n)
- ds = map (mkFastString . ('d':) . show) [(1::Int)..n]
+ funName = TxtI $ dataName n
+ ds = map dataFieldName [1..n]
extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds
fun = JFunc (map TxtI ds) (checkD <> returnS extra_args)
@@ -215,7 +171,7 @@ stackManip = mconcat (map mkPush [1..32]) <>
where
mkPush :: Int -> JStat
mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n)
- as = map (TxtI . mkFastString . ('x':) . show) [1..n]
+ as = map varName [1..n]
fun = JFunc as ((sp |= sp + toJExpr n)
<> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a)
[1..] as))
@@ -228,7 +184,7 @@ stackManip = mconcat (map mkPush [1..32]) <>
bits = bitsIdx sig
n = length bits
h = last bits
- args = map (TxtI . mkFastString . ('x':) . show) [1..n]
+ args = map varName [1..n]
fun = JFunc args $
mconcat [ sp |= sp + toJExpr (h+1)
, mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args)
@@ -288,7 +244,7 @@ loadRegs :: JStat
loadRegs = mconcat $ map mkLoad [1..32]
where
mkLoad :: Int -> JStat
- mkLoad n = let args = map (TxtI . mkFastString . ("x"++) . show) [1..n]
+ mkLoad n = let args = map varName [1..n]
assign = zipWith (\a r -> toJExpr r |= toJExpr a)
args (reverse $ take n regsFromR1)
fname = TxtI $ mkFastString ("h$l" ++ show n)
=====================================
docs/users_guide/9.6.1-notes.rst
=====================================
@@ -132,6 +132,15 @@ Compiler
presented in this GHC version as a technology preview, bugs and
missing features are expected.
+- The JavaScript backend has been merged. GHC is now able to be built as a
+ cross-compiler targeting the JavaScript platform. The backend should be
+ considered a technology preview. As such it is not ready for use in
+ production, is not distributed in the GHC release bindists and requires the
+ user to manually build GHC as a cross-compiler. See the JavaScript backend
+ `wiki <https://gitlab.haskell.org/ghc/ghc/-/wikis/javascript-backend>`_ page
+ on the GHC wiki for the current status, project roadmap, build instructions
+ and demos.
+
- The :extension:`TypeInType` is now marked as deprecated. Its meaning has been included
in :extension:`PolyKinds` and :extension:`DataKinds`.
=====================================
docs/users_guide/codegens.rst
=====================================
@@ -95,6 +95,36 @@ was built this way. If it has then the native code generator probably
won't be available. You can check this information by calling
``ghc --info`` (see :ghc-flag:`--info`).
+.. _javascript-code-gen:
+
+JavaScript Code Generator
+------------------------------
+
+.. index::
+ single: JavaScript code generator
+
+This is an alternative code generator included in GHC 9.6 and above. It
+generates `ECMA-262 <https://tc39.es/ecma262/>`_ compliant JavaScript and is
+included as a technical preview. At time of writing, it is being actively
+developed but is not suitable for serious projects and production environments.
+The JavaScript backend is not distributed in the GHC bindist and requires a
+manual build. See `building the JavaScript backend
+<https://gitlab.haskell.org/ghc/ghc/-/wikis/javascript-backend/building>`_ page
+on the GHC wiki for build instructions.
+
+A JavaScript cross-compiling GHC produces an executable script, and a directory
+of the same name suffixed with ``.jsexe``. For example, compiling a file named
+``Foo.hs`` will produce an executable script ``Foo`` and a ``Foo.jsexe``
+directory. The script is a thin wrapper that calls `Node.js
+<https://nodejs.org/en/>`_ on the payload of the compiled Haskell code and can
+be run in the usual way, e.g., ``./Foo``, as long as ``node`` is in your
+environment . The actual payload is in ``<ModuleName>.jsexe/all.js``, for
+example ``Foo.jsexe/all.js``. This file is the Haskell program cross-compiled to
+JavaScript *concrete syntax* and can be wrapped in a ``<script>`` HTML tag. For
+a breakdown of the rest of the build artifacts see the `compiler output
+<https://gitlab.haskell.org/ghc/ghc/-/wikis/javascript-backend/building#compiler-output-and-build-artifacts>`_
+section in the wiki.
+
.. _unreg:
Unregisterised compilation
=====================================
rts/RtsSymbols.c
=====================================
@@ -925,6 +925,7 @@ extern char **environ;
SymI_HasProto(newArena) \
SymI_HasProto(arenaAlloc) \
SymI_HasProto(arenaFree) \
+ SymI_HasProto(rts_clearMemory) \
RTS_USER_SIGNALS_SYMBOLS \
RTS_INTCHAR_SYMBOLS
=====================================
rts/include/RtsAPI.h
=====================================
@@ -599,6 +599,51 @@ extern StgWord base_GHCziTopHandler_runNonIO_closure[];
/* ------------------------------------------------------------------------ */
+// This is a public RTS API function that does its best to zero out
+// unused RTS memory. rts_clearMemory() takes the storage manager
+// lock. It's only safe to call rts_clearMemory() when all mutators
+// have stopped and either minor/major garbage collection has just
+// been run.
+//
+// rts_clearMemory() works for all RTS ways on all platforms, though
+// the main intended use case is the pre-initialization of a
+// wasm32-wasi reactor module (#22920). A reactor module is like
+// shared library on other platforms, with foreign exported Haskell
+// functions as entrypoints. At run-time, the user calls hs_init_ghc()
+// to initialize the RTS, after that they can invoke Haskell
+// computation by calling the exported Haskell functions, persisting
+// the memory state across these invocations.
+//
+// Besides hs_init_ghc(), the user may want to invoke some Haskell
+// function to initialize some global state in the user code, this
+// global state is used by subsequent invocations. Now, it's possible
+// to run hs_init_ghc() & custom init logic in Haskell, then snapshot
+// the entire memory into a new wasm module! And the user can call the
+// new wasm module's exports directly, thus eliminating the
+// initialization overhead at run-time entirely.
+//
+// There's one problem though. After the custom init logic runs, the
+// RTS memory contains a lot of garbage data in various places. These
+// garbage data will be snapshotted into the new wasm module, causing
+// a significant size bloat. Therefore, we need an RTS API function
+// that zeros out unused RTS memory.
+//
+// At the end of the day, the custom init function will be a small C
+// function that first calls hs_init_ghc(), then calls a foreign
+// exported Haskell function to initialize whatever global state the
+// other Haskell functions need, followed by a hs_perform_gc() call to
+// do a major GC, and finally an rts_clearMemory() call to zero out
+// the unused RTS memory.
+//
+// Why add rts_clearMemory(), where there's the -DZ RTS flag that
+// zeros freed memory on GC? The -DZ flag actually fills freed memory
+// with a garbage byte like 0xAA, and the flag only works in debug
+// RTS. Why not add a new RTS flag that zeros freed memory on the go?
+// Because it only makes sense to do the zeroing once before
+// snapshotting the memory, but there's no point to pay for the
+// zeroing overhead at the new module's run-time.
+void rts_clearMemory(void);
+
#if defined(__cplusplus)
}
#endif
=====================================
rts/sm/BlockAlloc.c
=====================================
@@ -1395,3 +1395,17 @@ reportUnmarkedBlocks (void)
}
#endif
+
+void clear_free_list(void) {
+ for (uint32_t node = 0; node < n_numa_nodes; ++node) {
+ for (bdescr *bd = free_mblock_list[node]; bd != NULL; bd = bd->link) {
+ clear_blocks(bd);
+ }
+
+ for (int ln = 0; ln < NUM_FREE_LISTS; ++ln) {
+ for (bdescr *bd = free_list[node][ln]; bd != NULL; bd = bd->link) {
+ clear_blocks(bd);
+ }
+ }
+ }
+}
=====================================
rts/sm/BlockAlloc.h
=====================================
@@ -32,4 +32,6 @@ void reportUnmarkedBlocks (void);
extern W_ n_alloc_blocks; // currently allocated blocks
extern W_ hw_alloc_blocks; // high-water allocated blocks
+RTS_PRIVATE void clear_free_list(void);
+
#include "EndPrivate.h"
=====================================
rts/sm/NonMoving.h
=====================================
@@ -356,6 +356,10 @@ void print_thread_list(StgTSO* tso);
#endif
+RTS_PRIVATE void clear_segment(struct NonmovingSegment*);
+
+RTS_PRIVATE void clear_segment_free_blocks(struct NonmovingSegment*);
+
#include "EndPrivate.h"
#endif // CMINUSMINUS
=====================================
rts/sm/NonMovingSweep.c
=====================================
@@ -106,14 +106,16 @@ void nonmovingGcCafs()
debug_caf_list_snapshot = (StgIndStatic*)END_OF_CAF_LIST;
}
-static void
+#endif
+
+void
clear_segment(struct NonmovingSegment* seg)
{
size_t end = ((size_t)seg) + NONMOVING_SEGMENT_SIZE;
memset(&seg->bitmap, 0, end - (size_t)&seg->bitmap);
}
-static void
+void
clear_segment_free_blocks(struct NonmovingSegment* seg)
{
unsigned int block_size = nonmovingSegmentBlockSize(seg);
@@ -125,8 +127,6 @@ clear_segment_free_blocks(struct NonmovingSegment* seg)
}
}
-#endif
-
GNUC_ATTR_HOT void nonmovingSweep(void)
{
while (nonmovingHeap.sweep_list) {
=====================================
rts/sm/Storage.c
=====================================
@@ -1924,3 +1924,46 @@ The compacting collector does nothing to improve megablock
level fragmentation. The role of the compacting GC is to remove object level
fragmentation and to use less memory when collecting. - see #19248
*/
+
+void rts_clearMemory(void) {
+ ACQUIRE_SM_LOCK;
+
+ clear_free_list();
+
+ for (uint32_t i = 0; i < n_nurseries; ++i) {
+ for (bdescr *bd = nurseries[i].blocks; bd; bd = bd->link) {
+ clear_blocks(bd);
+ }
+ }
+
+ for (unsigned int i = 0; i < getNumCapabilities(); ++i) {
+ for (bdescr *bd = getCapability(i)->pinned_object_empty; bd; bd = bd->link) {
+ clear_blocks(bd);
+ }
+
+ for (bdescr *bd = gc_threads[i]->free_blocks; bd; bd = bd->link) {
+ clear_blocks(bd);
+ }
+ }
+
+ if (RtsFlags.GcFlags.useNonmoving)
+ {
+ for (struct NonmovingSegment *seg = nonmovingHeap.free; seg; seg = seg->link) {
+ clear_segment(seg);
+ }
+
+ for (int i = 0; i < NONMOVING_ALLOCA_CNT; ++i) {
+ struct NonmovingAllocator *alloc = nonmovingHeap.allocators[i];
+
+ for (struct NonmovingSegment *seg = alloc->active; seg; seg = seg->link) {
+ clear_segment_free_blocks(seg);
+ }
+
+ for (unsigned int j = 0; j < getNumCapabilities(); ++j) {
+ clear_segment_free_blocks(alloc->current[j]);
+ }
+ }
+ }
+
+ RELEASE_SM_LOCK;
+}
=====================================
rts/sm/Storage.h
=====================================
@@ -206,4 +206,8 @@ extern StgIndStatic * dyn_caf_list;
extern StgIndStatic * debug_caf_list;
extern StgIndStatic * revertible_caf_list;
+STATIC_INLINE void clear_blocks(bdescr *bd) {
+ memset(bd->start, 0, BLOCK_SIZE * bd->blocks);
+}
+
#include "EndPrivate.h"
=====================================
testsuite/tests/ffi/should_run/ffi023_c.c
=====================================
@@ -5,5 +5,6 @@
HsInt out (HsInt x)
{
performMajorGC();
+ rts_clearMemory();
return incall(x);
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/00251a836234fd2c77540a49af6acac27192686d...2c61b4f259f25ccad5fd1af03aea3fa8b5df33a9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/00251a836234fd2c77540a49af6acac27192686d...2c61b4f259f25ccad5fd1af03aea3fa8b5df33a9
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230215/ec3e518e/attachment-0001.html>
More information about the ghc-commits
mailing list