Chez Scheme GC: internal parallelism by messages instead of locks

Change the internal parallelism strategy for the GC to record an owner
for each allocated segment of memory, and have the owner be solely
responsible for copying or marking objects of the segment. When
sweeping, a collecting thread handles references to objects that it
owns or that have been copied or marked already, and it asks another
collecting thread to resweep an object that refers to objects owned by
that that thread. At worst, an object ends up being swept by all
collecting threads, one at a time, but that's unlikely for a given
object.

The approach seems likely to scale better than a lock-based approach,
even the one that used a lightweight, CAS-based lock and retries on
lock failure.
This commit is contained in:
Matthew Flatt 2020-09-22 11:47:08 -06:00
parent 4fdc896412
commit c46e4f91c1
21 changed files with 1089 additions and 626 deletions

View File

@ -338,7 +338,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
RACKET_FOR_BUILD = $(RACKET)
# This branch name changes each time the pb boot files are updated:
PB_BRANCH == circa-7.8.0.10-7
PB_BRANCH == circa-7.8.0.10-11
PB_REPO == https://github.com/racket/pb
# Alternative source for Chez Scheme boot files, normally set by

View File

@ -47,7 +47,7 @@ RACKETCS_SUFFIX =
RACKET =
RACKET_FOR_BOOTFILES = $(RACKET)
RACKET_FOR_BUILD = $(RACKET)
PB_BRANCH = circa-7.8.0.10-7
PB_BRANCH = circa-7.8.0.10-11
PB_REPO = https://github.com/racket/pb
EXTRA_REPOS_BASE =
CS_CROSS_SUFFIX =
@ -306,14 +306,14 @@ maybe-fetch-pb-as-is:
echo done
fetch-pb-from:
mkdir -p racket/src/ChezScheme/boot
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.8.0.10-7 https://github.com/racket/pb racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.8.0.10-7:remotes/origin/circa-7.8.0.10-7 ; fi
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.8.0.10-7
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.8.0.10-11 https://github.com/racket/pb racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.8.0.10-11:remotes/origin/circa-7.8.0.10-11 ; fi
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.8.0.10-11
pb-stage:
cd racket/src/ChezScheme/boot/pb && git branch circa-7.8.0.10-7
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.8.0.10-7
cd racket/src/ChezScheme/boot/pb && git branch circa-7.8.0.10-11
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.8.0.10-11
cd racket/src/ChezScheme/boot/pb && git add . && git commit --amend -m "new build"
pb-push:
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.8.0.10-7
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.8.0.10-11
win-cs-base:
IF "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-bc-then-cs-base SETUP_BOOT_MODE=--boot WIN32_BUILD_LEVEL=bc PLAIN_RACKET=racket\racketbc DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" GIT_CLONE_ARGS_qq="$(GIT_CLONE_ARGS_qq)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETBC_SUFFIX="$(RACKETBC_SUFFIX)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)"
IF not "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-just-cs-base SETUP_BOOT_MODE=--chain DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" GIT_CLONE_ARGS_qq="$(GIT_CLONE_ARGS_qq)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"

View File

@ -69,9 +69,11 @@ ${kernelobj}: ${Include}/equates.h ${Include}/scheme.h
${mainobj}: ${Include}/scheme.h
${kernelobj}: ${zlibHeaderDep} ${LZ4HeaderDep}
gc-011.o gc-par.o gc-ocd.o gc-oce.o: gc.c
gc-011.o gc-par.o gc-ocd.o: ${Include}/gc-ocd.inc
gc-011.o gc-ocd.o: ${Include}/gc-ocd.inc
gc-oce.o: ${Include}/gc-oce.inc
gc-par.o: ${Include}/gc-par.inc
vfasl.o: ${Include}/vfasl.inc
gcwrapper.o: ${Include}/heapcheck.inc
../zlib/zlib.h ../zlib/zconf.h: ../zlib/configure.log

View File

@ -80,6 +80,9 @@ void S_alloc_init() {
S_protect(&S_G.null_immutable_string);
find_room(tc, space_new, 0, type_typed_object, size_string(0), S_G.null_immutable_string);
STRTYPE(S_G.null_immutable_string) = (0 << string_length_offset) | type_string | string_immutable_flag;
S_protect(&S_G.zero_length_bignum);
S_G.zero_length_bignum = S_bignum(tc, 0, 0);
}
}

File diff suppressed because it is too large Load Diff

View File

@ -15,6 +15,7 @@
*/
#include "system.h"
#include "popcount.h"
/* locally defined functions */
static void segment_tell PROTO((uptr seg));
@ -545,6 +546,59 @@ void S_addr_tell(ptr p) {
segment_tell(addr_get_segment(p));
}
static void check_pointer(ptr *pp, IBOOL address_is_meaningful, ptr base, uptr seg, ISPC s, IBOOL aftergc) {
ptr p = *pp;
if (!IMMEDIATE(p)) {
seginfo *psi = MaybeSegInfo(ptr_get_segment(p));
if (psi != NULL) {
if ((psi->space == space_empty)
|| psi->old_space
|| (psi->marked_mask && !(psi->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))
/* corner case: a continuation in space_count_pure can refer to code via CLOSENTRY
where the entry point doesn't have a mark bit: */
&& !((s == space_count_pure) && (psi->space == space_code)))) {
S_checkheap_errors += 1;
printf("!!! dangling reference at %s"PHtx" to "PHtx"%s\n",
(address_is_meaningful ? "" : "insideof "),
(ptrdiff_t)(address_is_meaningful ? pp : TO_VOIDP(base)),
(ptrdiff_t)p, (aftergc ? " after gc" : ""));
printf("from: "); segment_tell(seg);
printf("to: "); segment_tell(ptr_get_segment(p));
{
ptr l;
for (l = S_G.locked_objects[psi->generation]; l != Snil; l = Scdr(l))
if (Scar(l) == p)
printf(" in locked\n");
for (l = S_G.unlocked_objects[psi->generation]; l != Snil; l = Scdr(l))
if (Scar(l) == p)
printf(" in unlocked\n");
}
abort(); // REMOVEME
}
}
}
}
static void check_bignum(ptr p) {
if (!Sbignump(p))
printf("!!! not a bignum %p\n", TO_VOIDP(p));
}
#include "heapcheck.inc"
static ptr *find_nl(ptr *pp1, ptr *pp2, ISPC s, IGEN g) {
ptr *nl, ls;
for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
ptr t_tc = (ptr)THREADTC(Scar(ls));
nl = TO_VOIDP(NEXTLOC_AT(t_tc, s, g));
if (pp1 <= nl && nl < pp2)
return nl;
}
return NULL;
}
static void check_heap_dirty_msg(msg, x) char *msg; ptr *x; {
INT d; seginfo *si;
@ -577,6 +631,13 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
printf("!!! inconsistent thread NEXT %p and BASE %p\n",
TO_VOIDP(NEXTLOC_AT(t_tc, s, g)), TO_VOIDP(BASELOC_AT(t_tc, s, g)));
}
if ((REMOTERANGEEND(t_tc) != (ptr)0)
|| (REMOTERANGESTART(t_tc) != (ptr)(uptr)-1)) {
S_checkheap_errors += 1;
printf("!!! nonempty thread REMOTERANGE %p-%p\n",
TO_VOIDP(REMOTERANGESTART(t_tc)),
TO_VOIDP(REMOTERANGEEND(t_tc)));
}
}
}
}
@ -669,67 +730,123 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
printf("!!! unexpected generation %d segment "PHtx" in space_new\n", g, (ptrdiff_t)seg);
}
} else if (s == space_impure || s == space_symbol || s == space_pure || s == space_weakpair || s == space_ephemeron
|| s == space_immobile_impure || s == space_count_pure || s == space_count_impure || s == space_closure) {
/* doesn't handle: space_port, space_continuation, space_code, space_pure_typed_object,
space_impure_record, or impure_typed_object */
|| s == space_immobile_impure || s == space_count_pure || s == space_count_impure || s == space_closure
|| s == space_pure_typed_object || s == space_continuation || s == space_port || s == space_code
|| s == space_impure_record || s == space_impure_typed_object) {
ptr start;
/* check for dangling references */
pp1 = TO_VOIDP(build_ptr(seg, 0));
pp2 = TO_VOIDP(build_ptr(seg + 1, 0));
nl = NULL;
{
ptr ls;
for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
ptr t_tc = (ptr)THREADTC(Scar(ls));
nl = TO_VOIDP(NEXTLOC_AT(t_tc, s, g));
if (pp1 <= nl && nl < pp2)
break;
}
}
nl = find_nl(pp1, pp2, s, g);
if (pp1 <= nl && nl < pp2) pp2 = nl;
while (pp1 < pp2) {
if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) {
int a;
for (a = 0; (a < ptr_alignment) && (pp1 < pp2); a++) {
#define in_ephemeron_pair_part(pp1, seg) ((((uptr)TO_PTR(pp1) - (uptr)build_ptr(seg, 0)) % size_ephemeron) < size_pair)
if ((s == space_ephemeron) && !in_ephemeron_pair_part(pp1, seg)) {
/* skip non-pair part of ephemeron */
if (s == space_pure_typed_object || s == space_port || s == space_code
|| s == space_impure_record || s == space_impure_typed_object) {
if (si->marked_mask) {
/* not implemented */
} else {
/* only check this segment for objects that start on it */
uptr before_seg = seg;
/* Back up over segments for the same space and generation: */
while (1) {
seginfo *before_si = MaybeSegInfo(before_seg-1);
if (!before_si
|| (before_si->space != si->space)
|| (before_si->generation != si->generation)
|| ((before_si->marked_mask == NULL) != (si->marked_mask == NULL)))
break;
before_seg--;
}
/* Move forward to reach `seg` again: */
start = build_ptr(before_seg, 0);
while (before_seg != seg) {
ptr *before_pp2, *before_nl;
before_pp2 = TO_VOIDP(build_ptr(before_seg + 1, 0));
if ((ptr *)TO_VOIDP(start) > before_pp2) {
/* skipped to a further segment */
before_seg++;
} else {
p = *pp1;
if (!si->marked_mask && (p == forward_marker)) {
pp1 = pp2; /* break out of outer loop */
break;
} else if (!IMMEDIATE(p)) {
seginfo *psi = MaybeSegInfo(ptr_get_segment(p));
if (psi != NULL) {
if ((psi->space == space_empty)
|| psi->old_space
|| (psi->marked_mask && !(psi->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))
/* corner case: a continuation in space_count_pure can refer to code via CLOSENTRY
where the entry point doesn't have a mark bit: */
&& !((s == space_count_pure) && (psi->space == space_code)))) {
S_checkheap_errors += 1;
printf("!!! dangling reference at "PHtx" to "PHtx"%s\n", (ptrdiff_t)pp1, (ptrdiff_t)p, (aftergc ? " after gc" : ""));
printf("from: "); segment_tell(seg);
printf("to: "); segment_tell(ptr_get_segment(p));
{
ptr l;
for (l = S_G.locked_objects[psi->generation]; l != Snil; l = Scdr(l))
if (Scar(l) == p)
printf(" in locked\n");
for (l = S_G.unlocked_objects[psi->generation]; l != Snil; l = Scdr(l))
if (Scar(l) == p)
printf(" in unlocked\n");
before_nl = find_nl(TO_VOIDP(start), before_pp2, s, g);
if (((ptr*)TO_VOIDP(start)) <= before_nl && before_nl < before_pp2) {
/* this segment ends, so move to next segment */
before_seg++;
if (s == space_code) {
/* in the case of code, it's possible for a whole segment to
go unused if a large code object didn't fit; give up, just in case */
start = build_ptr(seg+1, 0);
} else {
start = build_ptr(before_seg, 0);
}
} else {
while (((ptr *)TO_VOIDP(start)) < before_pp2) {
if (*(ptr *)TO_VOIDP(start) == forward_marker) {
/* this segment ends, so move to next segment */
if (s == space_code) {
start = build_ptr(seg+1, 0);
} else {
start = build_ptr(before_seg+1, 0);
}
} else {
start = (ptr)((uptr)start + size_object(TYPE(start, type_typed_object)));
}
}
before_seg++;
}
}
pp1 += 1;
}
} else
pp1 += ptr_alignment;
if (((ptr *)TO_VOIDP(start)) >= pp2) {
/* previous object extended past the segment */
} else {
pp1 = TO_VOIDP(start);
while (pp1 < pp2) {
if (*pp1 == forward_marker)
break;
else {
p = TYPE(TO_PTR(pp1), type_typed_object);
check_object(p, seg, s, aftergc);
pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + size_object(p)));
}
}
}
}
} else if (s == space_continuation) {
while (pp1 < pp2) {
if (*pp1 == forward_marker)
break;
if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) {
p = TYPE(TO_PTR(pp1), type_closure);
check_object(p, seg, s, aftergc);
}
pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + size_continuation));
}
} else {
while (pp1 < pp2) {
if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) {
int a;
for (a = 0; (a < ptr_alignment) && (pp1 < pp2); a++) {
#define in_ephemeron_pair_part(pp1, seg) ((((uptr)TO_PTR(pp1) - (uptr)build_ptr(seg, 0)) % size_ephemeron) < size_pair)
if ((s == space_ephemeron) && !in_ephemeron_pair_part(pp1, seg)) {
/* skip non-pair part of ephemeron */
} else {
p = *pp1;
if (!si->marked_mask && (p == forward_marker)) {
pp1 = pp2; /* break out of outer loop */
break;
} else {
check_pointer(pp1, 1, (ptr)0, seg, s, aftergc);
}
}
pp1 += 1;
}
} else
pp1 += ptr_alignment;
}
}
/* verify that dirty bits are set appropriately */

View File

@ -117,6 +117,7 @@ EXTERN struct S_G_struct {
ptr null_immutable_vector;
ptr null_immutable_fxvector;
ptr null_immutable_bytevector;
ptr zero_length_bignum;
seginfo *dirty_segments[DIRTY_SEGMENT_LISTS];
/* schsig.c */

View File

@ -330,6 +330,13 @@ static void idiot_checks() {
oops = 1;
}
if ((((code_flag_continuation << code_flags_offset) | (code_flag_mutable_closure << code_flags_offset))
& (uptr)forward_marker) != 0) {
/* parallel GC relies on not confusing a forward marker with code flags */
fprintf(stderr, "code flags overlap with forwadr_marker\n");
oops = 1;
}
if (oops) S_abnormal_exit();
}

View File

@ -235,7 +235,6 @@ static void initialize_seginfo(seginfo *si, NO_THREADS_UNUSED ptr tc, ISPC s, IG
si->use_marks = 0;
si->must_mark = 0;
#ifdef PTHREADS
si->lock = 0;
si->creator_tc = tc;
#endif
si->list_bits = NULL;

View File

@ -142,7 +142,8 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; {
LZ4OUTBUFFER(tc) = 0;
SWEEPER(tc) = -1;
LOCKSTATUS(tc) = Strue;
REMOTERANGESTART(tc) = (ptr)(uptr)-1;
REMOTERANGEEND(tc) = (ptr)0;
tc_mutex_release();

View File

@ -158,8 +158,7 @@ typedef struct _seginfo {
octet *list_bits; /* for `$list-bits-ref` and `$list-bits-set!` */
uptr number; /* the segment number */
#ifdef PTHREADS
ptr lock; /* for parallel GC */
ptr creator_tc; /* for parallelism heuristic; might not match an active thread */
ptr creator_tc; /* for GC parallelism heuristic; might not match an active thread unless old_space */
#endif
struct _chunkinfo *chunk; /* the chunk this segment belongs to */
struct _seginfo *next; /* pointer to the next seginfo (used in occupied_segments and unused_segs) */

View File

@ -1151,10 +1151,20 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets
t = CODERELOC(co);
t = ptr_add(vspaces[vspace_reloc], (uptr)t - vspace_offsets[vspace_reloc]);
if (to_static && !S_G.retain_static_relocation
&& ((CODETYPE(co) & (code_flag_template << code_flags_offset)) == 0))
CODERELOC(co) = (ptr)0;
else {
if (to_static && !S_G.retain_static_relocation) {
if ((CODETYPE(co) & (code_flag_template << code_flags_offset)) == 0)
CODERELOC(co) = (ptr)0;
else {
ptr tc = get_thread_context();
iptr sz = size_reloc_table(RELOCSIZE(t));
ptr new_t;
find_room(tc, space_data, static_generation, typemod, ptr_align(sz), new_t);
memcpy(TO_VOIDP(new_t), TO_VOIDP(t), sz);
t = new_t;
CODERELOC(co) = t;
RELOCCODE(t) = co;
}
} else {
CODERELOC(co) = t;
RELOCCODE(t) = co;
}

View File

@ -401,7 +401,9 @@
(status "Generate GC")
(eval `(mkgc-ocd.inc ,(path->string (build-path out-subdir "gc-ocd.inc"))))
(eval `(mkgc-oce.inc ,(path->string (build-path out-subdir "gc-oce.inc"))))
(eval `(mkgc-par.inc ,(path->string (build-path out-subdir "gc-par.inc"))))
(eval `(mkvfasl.inc ,(path->string (build-path out-subdir "vfasl.inc"))))
(eval `(mkheapcheck.inc ,(path->string (build-path out-subdir "heapcheck.inc"))))
(plumber-flush-all (current-plumber))))
(when (getenv "MAKE_BOOT_FOR_CROSS")

View File

@ -114,7 +114,9 @@ Cheader = ../boot/$m/scheme.h
Cequates = ../boot/$m/equates.h
Cgcocd = ../boot/$m/gc-ocd.inc
Cgcoce = ../boot/$m/gc-oce.inc
Cgcpar = ../boot/$m/gc-par.inc
Cvfasl = ../boot/$m/vfasl.inc
Cheapcheck = ../boot/$m/heapcheck.inc
Revision = ../boot/$m/revision
# The following controls the patch files loaded before compiling, typically used only
@ -171,11 +173,11 @@ allsrc =\
np-languages.ss fxmap.ss
# doit uses a different Scheme process to compile each target
doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cvfasl} ${Revision}
doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cvfasl} ${Cheapcheck} ${Revision}
# all uses a single Scheme process to compile all targets. this is typically
# faster when most of the targets need to be recompiled.
all: bootall ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cvfasl} ${Revision}
all: bootall ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cvfasl} ${Cheapcheck} ${Revision}
# allx runs all up to three times and checks to see if the new boot file is the
# same as the last, i.e., the system is properly bootstrapped.
@ -362,7 +364,7 @@ resetbootlinks:
| ${Scheme} -q
keepbootfiles:
for x in `echo scheme.boot petite.boot scheme.h equates.h gc-oce.inc gc-ocd.inc vfasl.inc` ; do\
for x in `echo scheme.boot petite.boot scheme.h equates.h gc-oce.inc gc-ocd.inc gc-par.inc vfasl.inc heapcheck.inc` ; do\
if [ ! -h ../boot/$(m)/$$x ] ; then \
mv -f ../boot/$(m)/$$x ../../boot/$(m)/$$x ;\
elif [ "${upupupbootdir}" != "../../.." ] ; then \
@ -633,6 +635,15 @@ ${Cgcoce}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.s
then mv -f ${Cgcoce}.bak ${Cgcoce};\
else rm -f ${Cgcoce}.bak; fi)
${Cgcpar}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
(if [ -r ${Cgcpar} ]; then mv -f ${Cgcpar} ${Cgcpar}.bak; fi)
echo '(reset-handler abort)'\
'(mkgc-par.inc "${Cgcpar}")' |\
${Scheme} -q ${macroobj} mkheader.so mkgc.so
(if `cmp -s ${Cgcpar} ${Cgcpar}.bak`;\
then mv -f ${Cgcpar}.bak ${Cgcpar};\
else rm -f ${Cgcpar}.bak; fi)
${Cvfasl}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
(if [ -r ${Cvfasl} ]; then mv -f ${Cvfasl} ${Cvfasl}.bak; fi)
echo '(reset-handler abort)'\
@ -642,6 +653,15 @@ ${Cvfasl}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.s
then mv -f ${Cvfasl}.bak ${Cvfasl};\
else rm -f ${Cvfasl}.bak; fi)
${Cheapcheck}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
(if [ -r ${Cheapcheck} ]; then mv -f ${Cheapcheck} ${Cheapcheck}.bak; fi)
echo '(reset-handler abort)'\
'(mkheapcheck.inc "${Cheapcheck}")' |\
${Scheme} -q ${macroobj} mkheader.so mkgc.so
(if `cmp -s ${Cheapcheck} ${Cheapcheck}.bak`;\
then mv -f ${Cheapcheck}.bak ${Cheapcheck};\
else rm -f ${Cheapcheck}.bak; fi)
.PHONY: ${Revision}
${Revision}: update-revision
@./update-revision > ${Revision}
@ -664,7 +684,9 @@ reset:
$(MAKE) reset-one FILE=scheme.h
$(MAKE) reset-one FILE=gc-oce.inc
$(MAKE) reset-one FILE=gc-ocd.inc
$(MAKE) reset-one FILE=gc-par.inc
$(MAKE) reset-one FILE=vfasl.inc
$(MAKE) reset-one FILE=heapcheck.inc
.PHONY: reset-one
reset-one:

View File

@ -855,6 +855,8 @@
;; ---------------------------------------------------------------------
;; Bit and byte offsets for different types of objects:
;; Flags that matter to the GC must apply only to static-generation
;; objects, and they must not overlap with `forward-marker`
(define-constant code-flag-system #b0000001)
(define-constant code-flag-continuation #b0000010)
(define-constant code-flag-template #b0000100)
@ -1389,7 +1391,8 @@
(define-primitive-structure-disps ratnum type-typed-object
([iptr type]
[ptr numerator]
[ptr denominator]))
[ptr denominator]
[iptr pad])) ; for alignment
(define-primitive-structure-disps vector type-typed-object
([iptr type]
@ -1433,7 +1436,8 @@
(define-primitive-structure-disps exactnum type-typed-object
([iptr type]
[ptr real]
[ptr imag]))
[ptr imag]
[iptr pad])) ; for alignment
(define-primitive-structure-disps closure type-closure
([ptr code]
@ -1495,8 +1499,9 @@
(define-constant virtual-register-count 16)
(define-constant static-generation 7)
(define-constant num-generations (fx+ (constant static-generation) 1))
(define-constant num-thread-local-allocation-segments (fx* (fx+ 1 (constant static-generation))
(fx+ 1 (constant max-real-space))))
(define-constant num-spaces (fx+ (constant max-real-space) 1))
(define-constant num-thread-local-allocation-segments (fx* (constant num-generations)
(constant num-spaces)))
(define-constant maximum-parallel-collect-threads 8)
;;; make sure gc sweeps all ptrs
@ -1577,6 +1582,7 @@
[xptr base-loc (constant num-thread-local-allocation-segments)]
[xptr next-loc (constant num-thread-local-allocation-segments)]
[iptr bytes-left (constant num-thread-local-allocation-segments)]
[xptr orig-next-loc (constant num-spaces)]
[xptr sweep-loc (constant num-thread-local-allocation-segments)]
[xptr sweep-next (constant num-thread-local-allocation-segments)]
[xptr pending-ephemerons]
@ -1585,7 +1591,9 @@
[xptr sweep-stack-start]
[xptr sweep-stack-limit]
[iptr sweep-change]
[xptr lock-status]
[iptr remote-sweeper]
[xptr remote-range-start]
[xptr remote-range-end]
[iptr bitmask-overhead (constant num-generations)]))
(define tc-field-list

View File

@ -13,7 +13,9 @@
(disable-unbound-warning
mkgc-ocd.inc
mkgc-oce.inc
mkvfasl.inc)
mkgc-par.inc
mkvfasl.inc
mkheapcheck.inc)
;; Currently supported traversal modes:
;; - copy
@ -25,6 +27,7 @@
;; - measure : recurs for reachable size
;; - vfasl-copy
;; - vfasl-sweep
;; - check
;; For the specification, there are a few declaration forms described
;; below, such as `trace` to declare a pointer-valued field within an
@ -83,6 +86,7 @@
;; - (trace-early <field>) : relocate for sweep, copy, and mark; recur otherwise; implies pure
;; - (trace-now <field>) : direct recur; implies pure
;; - (trace-early-rtd <field>) : for record types, avoids recur on #!base-rtd; implies pure
;; - (trace-pure-code <field>) : like `trace-pure`, but special handling in parallel mode
;; - (trace-ptrs <field> <count>) : trace an array of pointerrs
;; - (trace-pure-ptrs <field> <count>) : pure analog of `trace-ptrs`
;; - (copy <field>) : copy for copy, ignore otherwise
@ -96,8 +100,6 @@
;; - (as-mark-end <statment> ...) : declares that <statement>s implement counting,
;; which means that it's included for mark mode
;; - (skip-forwarding) : disable forward-pointer installation in copy mode
;; - (check-lock-failed) : bail out if a lock aquire failed; use this before dereferencing
;; an object reference that might not have been relocated
;; - (assert <expr>) : assertion
;;
;; In the above declarations, nonterminals like <space> can be
@ -150,6 +152,7 @@
;; Built-in variables:
;; - _ : object being copied, swept, etc.
;; - _copy_ : target in copy or vfasl mode, same as _ otherwise
;; - _size_ : size of the current object, but only in parallel mode
;; - _tf_ : type word
;; - _tg_ : target generation
;; - _backreferences?_ : dynamic flag indicating whether backreferences are on
@ -173,6 +176,9 @@
[(copy)
(set! (ephemeron-prev-ref _copy_) 0)
(set! (ephemeron-next _copy_) 0)]
[(check)
(trace pair-car)
(trace pair-cdr)]
[else])
(add-ephemeron-to-pending)
(mark one-bit no-sweep)
@ -181,6 +187,9 @@
[space-weakpair
(space space-weakpair)
(vfasl-fail "weakpair")
(case-mode
[(check) (trace pair-car)]
[else])
(try-double-pair copy pair-car
trace pair-cdr
countof-weakpair)]
@ -193,7 +202,10 @@
[closure
(define code : ptr (CLOSCODE _))
(trace-code-early code)
(trace-code-early code) ; not traced in parallel mode
;; In parallel mode, don't use any fields of `code` until the
;; second on after the type, because the type and first field may
;; be overwritten with forwarding information
(cond
[(and-not-as-dirty
(or-assume-continuation
@ -221,12 +233,23 @@
(case-mode
[(sweep)
(define stk : ptr (continuation-stack _))
(when (&& (!= stk (cast ptr 0)) (OLDSPACE stk))
(set! (continuation-stack _)
(copy_stack _tc_
(continuation-stack _)
(& (continuation-stack-length _))
(continuation-stack-clength _))))]
(define s_si : seginfo* NULL)
(when (&& (!= stk (cast ptr 0))
(begin
(set! s_si (SegInfo (ptr_get_segment stk)))
(-> s_si old_space)))
(cond
[(! (SEGMENT_IS_LOCAL s_si stk))
;; A stack segment has a single owner, so it's ok for us
;; to sweep the stack content, even though it's on a
;; remote segment relative to the current sweeper.
(RECORD_REMOTE_RANGE _tc_ _ _size_ s_si)]
[else
(set! (continuation-stack _)
(copy_stack _tc_
(continuation-stack _)
(& (continuation-stack-length _))
(continuation-stack-clength _)))]))]
[else])
(count countof-stack (continuation-stack-length _) 1 [measure])
(trace-pure continuation-link)
@ -250,9 +273,15 @@
[else
(cond
[(& (code-type code) (<< code-flag-mutable-closure code-flags-offset))
;; in parallel mode, assume that code pointer is static and doesn't need to be swept
space-impure]
[else
space-pure])]))
(case-flag parallel?
[on
;; use space-closure so code reference (not a regular ptr) is swept correctly
space-closure]
[off
space-pure])])]))
(vspace vspace_closure)
(when-vfasl
(when (& (code-type code) (<< code-flag-mutable-closure code-flags-offset))
@ -286,7 +315,7 @@
(size size-symbol)
(mark one-bit)
(trace/define symbol-value val :vfasl-as (FIX (vfasl_symbol_to_index vfi _)))
(trace-symcode symbol-pvalue val)
(trace-local-symcode symbol-pvalue val)
(trace-nonself/vfasl-as-nil symbol-plist)
(trace-nonself symbol-name)
(trace-nonself/vfasl-as-nil symbol-splist)
@ -463,37 +492,33 @@
(count countof-box)]
[ratnum
(space space-data)
(space (case-flag parallel?
[on space-pure]
[off space-data]))
(vspace vspace_impure) ; would be better if we had pure, but these are rare
(size size-ratnum)
(copy-type ratnum-type)
(trace-now ratnum-numerator)
(trace-now ratnum-denominator)
(case-mode
[(copy) (when (CHECK_LOCK_FAILED _tc_)
;; create failed relocates so that the heap checker isn't unhappy
(set! (ratnum-numerator _copy_) (cast ptr 0))
(set! (ratnum-denominator _copy_) (cast ptr 0)))]
[(mark) (check-lock-failed)]
[else])
(trace-nonparallel-now ratnum-numerator)
(trace-nonparallel-now ratnum-denominator)
(case-flag parallel?
[on (pad (set! (ratnum-pad _copy_) 0))]
[off])
(mark)
(vfasl-pad-word)
(count countof-ratnum)]
[exactnum
(space space-data)
(space (case-flag parallel?
[on space-pure]
[off space-data]))
(vspace vspace_impure) ; same rationale as ratnum
(size size-exactnum)
(copy-type exactnum-type)
(trace-now exactnum-real)
(trace-now exactnum-imag)
(case-mode
[(copy) (when (CHECK_LOCK_FAILED _tc_)
;; create failed relocates so that the heap checker isn't unhappy
(set! (exactnum-real _copy_) (cast ptr 0))
(set! (exactnum-imag _copy_) (cast ptr 0)))]
[(mark) (check-lock-failed)]
[else])
(trace-nonparallel-now exactnum-real)
(trace-nonparallel-now exactnum-imag)
(case-flag parallel?
[on (pad (set! (exactnum-pad _copy_) 0))]
[off])
(mark)
(vfasl-pad-word)
(count countof-exactnum)]
@ -613,6 +638,11 @@
[else
(trace-nonself field)]))
(define-trace-macro (trace-nonparallel-now field)
(case-flag parallel?
[on (trace-pure field)]
[off (trace-now field)]))
(define-trace-macro (try-double-pair do-car pair-car
do-cdr pair-cdr
count-pair)
@ -680,7 +710,16 @@
;; Special relocation handling for code in a closure:
(set! code (vfasl_relocate_code vfi code))]
[else
(trace-early (just code))])))
;; In parallel mode, the `code` pointer may or may not have been
;; forwarded. In that case, we may misinterpret the forward mmarker
;; as a code type with flags, but it's ok, because the flags will
;; only be set for static-generation objects
(case-flag parallel?
[on (case-mode
[(sweep sweep-in-old)
(trace-pure-code (just code))]
[else])]
[off (trace-early (just code))])])))
(define-trace-macro (copy-clos-code code)
(case-mode
@ -718,7 +757,6 @@
(trace ref)]
[(sweep sweep-in-old)
(trace ref) ; can't trace `val` directly, because we need an impure relocate
(check-lock-failed)
(define val : ptr (ref _))]
[vfasl-copy
(set! (ref _copy_) vfasl-val)]
@ -733,7 +771,6 @@
(case-flag as-dirty?
[on (trace (just code))]
[off (trace-pure (just code))])
(check-lock-failed)
(INITSYMCODE _ code)]
[measure]
[vfasl-copy
@ -741,6 +778,27 @@
[else
(copy symbol-pvalue)]))
(define-trace-macro (trace-local-symcode symbol-pvalue val)
(case-mode
[(sweep)
(case-flag parallel?
[on
(define v_si : seginfo* (cond
[(Sprocedurep val) (SegInfo (ptr_get_segment val))]
[else NULL]))
(cond
[(\|\|
(\|\|
(== v_si NULL)
(! (-> v_si old_space)))
(SEGMENT_IS_LOCAL v_si val))
(trace-symcode symbol-pvalue val)]
[else
(RECORD_REMOTE_RANGE _tc_ _ _size_ v_si)])]
[off (trace-symcode symbol-pvalue val)])]
[else
(trace-symcode symbol-pvalue val)]))
(define-trace-macro (trace-tlc tlc-next tlc-keyval)
(case-mode
[(copy mark)
@ -800,11 +858,24 @@
[on]
[off
(case-mode
[(sweep sweep-in-old self-test)
;; Bignum pointer mask may need forwarding
(trace-pure (record-type-pm rtd))
(check-lock-failed)
(set! num (record-type-pm rtd))]
[(sweep)
(case-flag parallel?
[on
(define pm_si : seginfo* (SegInfo (ptr_get_segment num)))
(cond
[(\|\|
(! (-> pm_si old_space))
(SEGMENT_IS_LOCAL pm_si num))
(trace-record-type-pm num rtd)]
[else
;; Try again in the bignum's sweeper
(RECORD_REMOTE_RANGE _tc_ _ _size_ pm_si)
(set! num S_G.zero_length_bignum)])]
[off
(trace-record-type-pm num rtd)])]
[(sweep-in-old self-test)
(trace-record-type-pm num rtd)]
[(check) (check-bignum num)]
[else])])
(let* ([index : iptr (- (BIGLEN num) 1)]
;; Ignore bit for already forwarded rtd
@ -825,6 +896,11 @@
(set! mask (bignum-data num index))
(set! bits bigit_bits)))]))]))
(define-trace-macro (trace-record-type-pm num rtd)
;; Bignum pointer mask may need forwarding
(trace-pure (record-type-pm rtd))
(set! num (record-type-pm rtd)))
(define-trace-macro (vfasl-check-parent-rtd rtd)
(case-mode
[(vfasl-copy)
@ -917,7 +993,7 @@
(cast iptr (port-buffer _))))
(trace port-buffer)
(set! (port-last _) (cast ptr (+ (cast iptr (port-buffer _)) n))))]
[sweep-in-old
[(sweep-in-old check)
(when (& (cast uptr _tf_) flag)
(trace port-buffer))]
[else
@ -1024,10 +1100,19 @@
(trace-pure (* pp)))
(set! mask >>= 1)))]
[else
(trace-pure (* (ENTRYNONCOMPACTLIVEMASKADDR oldret)))
(check-lock-failed)
(let* ([num : ptr (ENTRYLIVEMASK oldret)]
[index : iptr (BIGLEN num)])
(case-mode
[(check) (check-bignum num)]
[else
(define n_si : seginfo* (SegInfo (ptr_get_segment num)))
(cond
[(! (-> n_si old_space))]
[(SEGMENT_IS_LOCAL n_si num)
(trace-pure (* (ENTRYNONCOMPACTLIVEMASKADDR oldret)))
(set! num (ENTRYLIVEMASK oldret))]
[else
(RECORD_REMOTE_RANGE _tc_ _ _size_ n_si)
(set! num S_G.zero_length_bignum)])])
(let* ([index : iptr (BIGLEN num)])
(while
:? (!= index 0)
(set! index -= 1)
@ -1055,11 +1140,10 @@
[(sweep sweep-in-old)
(define x_si : seginfo* (SegInfo (ptr_get_segment c_p)))
(when (-> x_si old_space)
(relocate_code c_p x_si)
(relocate_code c_p x_si _ _size_)
(case-mode
[sweep-in-old]
[else
(check-lock-failed)
(set! field (cast ptr (+ (cast uptr c_p) co)))]))]
[else
(trace-pure (just c_p))]))
@ -1116,7 +1200,6 @@
(case-mode
[sweep
(check-lock-failed)
(cond
[(&& (== from_g static_generation)
(&& (! S_G.retain_static_relocation)
@ -1126,21 +1209,20 @@
(let* ([t_si : seginfo* (SegInfo (ptr_get_segment t))])
(when (-> t_si old_space)
(cond
[(SEGMENT_LOCK_ACQUIRE t_si)
[(SEGMENT_IS_LOCAL t_si t)
(set! n (size_reloc_table (reloc-table-size t)))
(count countof-relocation-table (just n) 1 sweep)
(cond
[(-> t_si use_marks)
;; Assert: (! (marked t_si t))
(mark_typemod_data_object _tc_ t n t_si)]
(cond
[(! (marked t_si t))
(mark_typemod_data_object _tc_ t n t_si)])]
[else
(let* ([oldt : ptr t])
(find_room _tc_ space_data from_g typemod n t)
(memcpy_aligned (TO_VOIDP t) (TO_VOIDP oldt) n))])
(SEGMENT_LOCK_RELEASE t_si)]
(memcpy_aligned (TO_VOIDP t) (TO_VOIDP oldt) n))])]
[else
(RECORD_LOCK_FAILED _tc_ t_si)
(check-lock-failed)])))
(RECORD_REMOTE_RANGE _tc_ _ _size_ t_si)])))
(set! (reloc-table-code t) _)
(set! (code-reloc _) t)])
(S_record_code_mod tc_in (cast uptr (TO_PTR (& (code-data _ 0)))) (cast uptr (code-length _)))]
@ -1150,6 +1232,10 @@
(set! (code-reloc _) (cast ptr (ptr_diff t (-> vfi base_addr))))]
[else])]))
(define-trace-macro (check-bignum var)
(trace (just var))
(check_bignum var))
(define-trace-macro (unless-code-relocated stmt)
(case-flag code-relocated?
[on]
@ -1389,6 +1475,7 @@
[(lookup 'as-dirty? config #f) ", IGEN youngest"]
[(lookup 'no-from-g? config #f) ""]
[else ", IGEN from_g"])]
[(check) ", uptr seg, ISPC s_in, IBOOL aftergc"]
[else ""]))
(let ([body
(lambda ()
@ -1417,14 +1504,11 @@
(case (lookup 'mode config)
[(copy)
(code-block
"ENABLE_LOCK_ACQUIRE"
"if (CHECK_LOCK_FAILED(tc_in)) return 0xff;"
"check_triggers(tc_in, si);"
(code-block
"ptr new_p;"
"IGEN tg = TARGET_GENERATION(si);"
(body)
"if (CHECK_LOCK_FAILED(tc_in)) return 0xff;"
"SWEEPCHANGE(tc_in) = SWEEP_CHANGE_PROGRESS;"
"FWDMARKER(p) = forward_marker;"
"FWDADDRESS(p) = new_p;"
@ -1434,17 +1518,14 @@
"return tg;"))]
[(mark)
(code-block
"ENABLE_LOCK_ACQUIRE"
"if (CHECK_LOCK_FAILED(tc_in)) return 0xff;"
"check_triggers(tc_in, si);"
(ensure-segment-mark-mask "si" "" '())
(ensure-segment-mark-mask "si" "")
(body)
"SWEEPCHANGE(tc_in) = SWEEP_CHANGE_PROGRESS;"
"ADD_BACKREFERENCE(p, si->generation);"
"return si->generation;")]
[(sweep)
(code-block
"ENABLE_LOCK_ACQUIRE"
(and (lookup 'maybe-backreferences? config #f)
"PUSH_BACKREFERENCE(p)")
(body)
@ -1453,9 +1534,7 @@
(and (lookup 'as-dirty? config #f)
"return youngest;"))]
[(sweep-in-old)
(code-block
"ENABLE_LOCK_ACQUIRE"
(body))]
(body)]
[(measure)
(body)]
[(self-test)
@ -1579,8 +1658,8 @@
(code
"/* Do not inspect the type or first field of the rtd, because"
" it may have been overwritten for forwarding. */")])]
[(measure sweep sweep-in-old)
(statements `((trace-early ,field)) config)]
[(measure sweep sweep-in-old check)
(statements `((trace-early ,field)) (cons `(early-rtd? #t) config))]
[else #f])
(statements (cdr l) (cons `(copy-extra-rtd ,field) config)))]
[`(trace ,field)
@ -1590,9 +1669,12 @@
(code (and (not (lookup 'as-dirty? config #f))
(trace-statement field config #f 'pure))
(statements (cdr l) config))]
[`(trace-pure-code ,field)
(code (and (not (lookup 'as-dirty? config #f))
(trace-statement field (cons `(early-code? #t) config) #f 'pure))
(statements (cdr l) config))]
[`(trace-early ,field)
(code (trace-statement field config #t 'pure)
(check-lock-failure-statement config)
(statements (cdr l) (if (symbol? field)
(cons `(copy-extra ,field) config)
config)))]
@ -1680,7 +1762,7 @@
(statements (cons `(copy-bytes ,offset (* ptr_bytes ,len))
(cdr l))
config)]
[(sweep measure sweep-in-old vfasl-sweep)
[(sweep measure sweep-in-old vfasl-sweep check)
(code
(loop-over-pointers
(field-expression offset config "p" #t)
@ -1855,10 +1937,6 @@
(statements (list count-stmt) config)))]
[else
(statements (cdr l) config)])]
[`(check-lock-failed)
(code
(check-lock-failure-statement config)
(statements (cdr l) config))]
[`(define ,id : ,type ,rhs)
(let* ([used (lookup 'used config)]
[prev-used? (hashtable-ref used id #f)])
@ -1981,6 +2059,12 @@
[`_copy_ (case (lookup 'mode config)
[(copy vfasl-copy) "new_p"]
[else "p"])]
[`_size_
(cond
[(lookup 'parallel? config #f)
(hashtable-set! (lookup 'used config) 'p_sz #t)
"p_sz"]
[else "SIZE"])]
[`_tf_
(lookup 'tf config "TYPEFIELD(p)")]
[`_tg_
@ -2052,6 +2136,8 @@
(expression (car (apply-macro m (list a))) config protect? multiline?))]
[else
(protect (format "~a(~a)" op (expression a config #t)))])]
[`(begin ,a ,b)
(format "(~a, ~a)" (expression a config #t) (expression b config #t))]
[`(,op ,a ,b)
(cond
[(memq op '(& && \|\| == != + - * < > <= >= << >> ->))
@ -2118,23 +2204,38 @@
(measure-statement (field-expression field config "p" #f))]
[(eq? mode 'self-test)
(format "if (p == ~a) return 1;" (field-expression field config "p" #f))]
[(eq? mode 'check)
(format "check_pointer(&(~a), ~a, ~a, seg, s_in, aftergc);"
(field-expression field config "p" #f)
(match field
[`(just ,_) "0"]
[else "1"])
(expression '_ config))]
[else #f]))
(define (relocate-statement purity e config)
(define mode (lookup 'mode config))
(define (get-start) (expression '_ config))
(define (get-size) (cond
[(lookup 'early-rtd? config #f)
(expression '(size_record_inst (UNFIX (record-type-size (record-type _)))) config)]
[(lookup 'early-code? config #f)
(expression '(size_closure (CODEFREE (CLOSCODE _))) config)]
[else
(expression '_size_ config)]))
(case mode
[(vfasl-sweep)
(format "vfasl_relocate(vfi, &~a);" e)]
[(sweep-in-old)
(if (eq? purity 'pure)
(format "relocate_pure(&~a);" e)
(format "relocate_indirect(~a);" e))]
(format "relocate_pure(&~a, ~a, ~a);" e (get-start) (get-size))
(format "relocate_indirect(~a, ~a, ~a);" e (get-start) (get-size)))]
[else
(if (lookup 'as-dirty? config #f)
(begin
(when (eq? purity 'pure) (error 'relocate-statement "pure as dirty?"))
(format "relocate_dirty(&~a, youngest);" e))
(format "relocate_~a(&~a~a);" purity e (if (eq? purity 'impure) ", from_g" "")))]))
(format "relocate_dirty(&~a, youngest, ~a, ~a);" e (get-start) (get-size)))
(format "relocate_~a(&~a~a, ~a, ~a);" purity e (if (eq? purity 'impure) ", from_g" "") (get-start) (get-size)))]))
(define (measure-statement e)
(code
@ -2243,26 +2344,19 @@
" seginfo *mark_si; IGEN g;"
" si->marked_count += ((uptr)build_ptr(seg+1,0)) - addr;"
" seg++;"
" /* Note: taking a sequence of locks for a span of segments */"
" while (seg < end_seg) {"
" ENABLE_LOCK_ACQUIRE"
" mark_si = SegInfo(seg);"
" SEGMENT_LOCK_MUST_ACQUIRE(mark_si);"
" g = mark_si->generation;"
" if (!fully_marked_mask[g]) init_fully_marked_mask(tc_in, g);"
" mark_si->marked_mask = fully_marked_mask[g];"
" mark_si->marked_count = bytes_per_segment;"
" SEGMENT_LOCK_RELEASE(mark_si);"
" seg++;"
" }"
" mark_si = SegInfo(end_seg);"
" {"
" ENABLE_LOCK_ACQUIRE"
" SEGMENT_LOCK_MUST_ACQUIRE(mark_si);"
(ensure-segment-mark-mask "mark_si" " " '())
(ensure-segment-mark-mask "mark_si" " ")
" /* no need to set a bit: it's enough to have made `marked_mask` non-NULL */"
" mark_si->marked_count += addr + p_sz - (uptr)build_ptr(end_seg,0);"
" SEGMENT_LOCK_RELEASE(mark_si);"
" }"
"}")]))]
[within-segment?
@ -2294,13 +2388,11 @@
"else"
(within-loop-statement (code
" seginfo *mark_si = SegInfo(ptr_get_segment(mark_p));"
" ENABLE_LOCK_ACQUIRE"
" SEGMENT_LOCK_MUST_ACQUIRE(mark_si);"
(ensure-segment-mark-mask "mark_si" " " '()))
(ensure-segment-mark-mask "mark_si" " "))
"mark_si"
step
#t
" SEGMENT_LOCK_RELEASE(mark_si);")))])
#f)))])
(cond
[no-sweep? #f]
[else
@ -2312,20 +2404,6 @@
(code-block push))]
[else push]))]))))
(define (check-lock-failure-statement config)
(let ([mode (lookup 'mode config)])
(case mode
[(copy mark sweep)
(code
"if (CHECK_LOCK_FAILED(tc_in))"
(case mode
[(copy mark) (code-block "return 0xff;")]
[(sweep sweep-in-old)
(if (lookup 'as-dirty? config #f)
(code-block "return 0xff;")
(code-block "return;"))]))]
[else #f])))
(define (field-expression field config arg protect?)
(if (symbol? field)
(cond
@ -2359,15 +2437,11 @@
(error 'field-ref "index not allowed for non-array field ~s" acc-name))
(format "~a(~a)" c-ref obj)])))
(define (ensure-segment-mark-mask si inset flags)
(define (ensure-segment-mark-mask si inset)
(code
(format "~aif (!~a->marked_mask) {" inset si)
(format "~a find_room_voidp(tc_in, space_data, ~a->generation, ptr_align(segment_bitmap_bytes), ~a->marked_mask);"
(format "~a init_mask(tc_in, ~a->marked_mask, ~a->generation, 0);"
inset si si)
(if (memq 'no-clear flags)
(format "~a /* no clearing needed */" inset)
(format "~a memset(~a->marked_mask, 0, segment_bitmap_bytes);" inset si))
(format "~a S_G.bitmask_overhead[~a->generation] += ptr_align(segment_bitmap_bytes);" inset si)
(format "~a}" inset)))
(define (just-mark-bit-space? sp)
@ -2534,25 +2608,29 @@
(loop (cdr l))))]
[else (cons (car l) (loop (cdr l)))]))))
(define (gen-gc ofn count? measure?)
(define (gen-gc ofn count? measure? parallel?)
(guard
(x [#t (raise x)])
(parameterize ([current-output-port (open-output-file ofn 'replace)])
(print-code (generate "copy"
`((mode copy)
(maybe-backreferences? ,count?)
(counts? ,count?))))
(counts? ,count?)
(parallel? ,parallel?))))
(print-code (generate "sweep"
`((mode sweep)
(maybe-backreferences? ,count?)
(counts? ,count?))))
(counts? ,count?)
(parallel? ,parallel?))))
(print-code (generate "sweep_object_in_old"
`((mode sweep-in-old)
(maybe-backreferences? ,count?))))
(maybe-backreferences? ,count?)
(parallel? ,parallel?))))
(print-code (generate "sweep_dirty_object"
`((mode sweep)
(maybe-backreferences? ,count?)
(counts? ,count?)
(parallel? ,parallel?)
(as-dirty? #t))))
(letrec ([sweep1
(case-lambda
@ -2566,26 +2644,32 @@
(known-types (,type))
(maybe-backreferences? ,count?)
(counts? ,count?)))))])])
(sweep1 'record "sweep_record" '())
(sweep1 'record "sweep_dirty_record" '((as-dirty? #t)))
(sweep1 'symbol)
(sweep1 'symbol "sweep_dirty_symbol" '((as-dirty? #t)))
(sweep1 'thread "sweep_thread" '((no-from-g? #t)))
(sweep1 'port)
(sweep1 'port "sweep_dirty_port" '((as-dirty? #t)))
(sweep1 'closure "sweep_continuation" '((code-relocated? #t)
(assume-continuation? #t)))
(sweep1 'code "sweep_code_object"))
(sweep1 'record "sweep_record" `((parallel? ,parallel?)))
(sweep1 'record "sweep_dirty_record" `((as-dirty? #t)
(parallel? ,parallel?)))
(sweep1 'symbol "sweep_symbol" `((parallel? ,parallel?)))
(sweep1 'symbol "sweep_dirty_symbol" `((as-dirty? #t)
(parallel? ,parallel?)))
(sweep1 'thread "sweep_thread" `((no-from-g? #t)
(parallel? ,parallel?)))
(sweep1 'port "sweep_port" `((parallel? ,parallel?)))
(sweep1 'port "sweep_dirty_port" `((as-dirty? #t)
(parallel? ,parallel?)))
(sweep1 'closure "sweep_continuation" `((code-relocated? #t)
(assume-continuation? #t)
(parallel? ,parallel?)))
(sweep1 'code "sweep_code_object" `((parallel? ,parallel?))))
(print-code (generate "size_object"
`((mode size))))
(print-code (generate "mark_object"
`((mode mark)
(counts? ,count?))))
(counts? ,count?)
(parallel? ,parallel?))))
(print-code (generate "object_directly_refers_to_self"
`((mode self-test))))
(print-code (code "static void mark_typemod_data_object(ptr tc_in, ptr p, uptr p_sz, seginfo *si)"
(code-block
(ensure-segment-mark-mask "si" "" '())
(ensure-segment-mark-mask "si" "")
(mark-statement '(one-bit no-sweep)
(cons
(list 'used (make-eq-hashtable))
@ -2603,11 +2687,22 @@
`((mode vfasl-sweep)
(return-size? #t)))))))
(define (gen-heapcheck ofn)
(guard
(x [#t (raise x)])
(parameterize ([current-output-port (open-output-file ofn 'replace)])
(print-code (generate "check_object"
`((mode check))))
(print-code (generate "size_object"
`((mode size)))))))
;; Render via mkequates to record a mapping from selectors to C
;; macros:
(let-values ([(op get) (open-bytevector-output-port (native-transcoder))])
(mkequates.h op))
(set! mkgc-ocd.inc (lambda (ofn) (gen-gc ofn #f #f)))
(set! mkgc-oce.inc (lambda (ofn) (gen-gc ofn #t #t)))
(set! mkvfasl.inc (lambda (ofn) (gen-vfasl ofn))))
(set! mkgc-ocd.inc (lambda (ofn) (gen-gc ofn #f #f #f)))
(set! mkgc-oce.inc (lambda (ofn) (gen-gc ofn #t #t #f)))
(set! mkgc-par.inc (lambda (ofn) (gen-gc ofn #f #f #t)))
(set! mkvfasl.inc (lambda (ofn) (gen-vfasl ofn)))
(set! mkheapcheck.inc (lambda (ofn) (gen-heapcheck ofn))))

View File

@ -1006,10 +1006,12 @@
(defref EXACTNUM_TYPE exactnum type)
(defref EXACTNUM_REAL_PART exactnum real)
(defref EXACTNUM_IMAG_PART exactnum imag)
(defref EXACTNUM_PAD exactnum pad)
(defref RATTYPE ratnum type)
(defref RATNUM ratnum numerator)
(defref RATDEN ratnum denominator)
(defref RATPAD ratnum pad)
(defref CLOSENTRY closure code)
(defref CLOSIT closure data)

View File

@ -285,7 +285,9 @@ workdir $W/boot/$M
(cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/equates.h equates.h)
(cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/gc-ocd.inc gc-ocd.inc)
(cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/gc-oce.inc gc-oce.inc)
(cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/gc-par.inc gc-par.inc)
(cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/vfasl.inc vfasl.inc)
(cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/heapcheck.inc heapcheck.inc)
(cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/petite.boot petite.boot)
(cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/scheme.boot scheme.boot)
(cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/def.so def.so)

View File

@ -24,7 +24,9 @@ check_pb scheme.h
check_pb equates.h
check_pb gc-ocd.inc
check_pb gc-oce.inc
check_pb gc-par.inc
check_pb vfasl.inc
check_pb heapcheck.inc
check_mach()
{
@ -43,4 +45,6 @@ check_mach scheme.h
check_mach equates.h
check_mach gc-ocd.inc
check_mach gc-oce.inc
check_mach gc-par.inc
check_mach vfasl.inc
check_mach heapcheck.inc

View File

@ -22,6 +22,8 @@ ready_mach scheme.h
ready_mach equates.h
ready_mach gc-ocd.inc
ready_mach gc-oce.inc
ready_mach gc-par.inc
ready_mach vfasl.inc
ready_mach heapcheck.inc
rm -f boot_pending

View File

@ -22,4 +22,5 @@ ready_mach scheme.h
ready_mach equates.h
ready_mach gc-ocd.inc
ready_mach gc-oce.inc
ready_mach gc-par.inc
ready_mach vfasl.inc