suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added support for incremental promotion of objects

Browse Source 
- the collector now promotes objects one generation higher at a time
  by default.  previously, it promoted every live oldspace object to
  the selected target generation, which could result in objects
  prematurely skipping one or more generations and thus being
  retained longer than their ages justify.  the biggest cost in
  terms of code complexity and performance is the recording of
  pointers from older newspace objects to younger newspace objects
  that could not previously occur.
    gc.c, alloc.c, externs.h
- the collect procedure now takes an additional optional minimum
  target generation argument to allow the new default behavior to
  be overridden.
    7.ss, primdata.ss,
    gcwrapper.c,
    7.ms, root-experr*,
    smgmt.stex, release_notes.stex
- added cn flag to control collect-notify
    mats/Mf-base
- resweep_weak_pairs now sets sweep_loc to orig_next_loc rather than
  first_loc since the latter could result in unnecessary sweeping of
  existing target-generation weak pairs.
    gc.c
- added set of S_child_processes[newg] to S_child_processes[oldg]
  in S_do_gc code handling decreases in the maximum generation.
    gcwrapper.c
- a specialized variant of the collector is used in the common case
  where the max copied generation is 0, the min and max target
  generations are 1, and there are no locked generation 0 objects
  is now used. with the default collection parameters and no locking
  of generation 0 objects, these collections account for 3/4 of all
  collections.
    gc.c, gc-011.c (new), gcwrapper.c, externs.h, c/Mf-base
- maybe-fire-collector no longer tries to be so precise and instead
  just counts the number of generation-bytes allocated since the
  last gc.  suprisingly, rebuilding the s directory requires about
  the same number of collections with this coarser (and less
  expensive) measurement.  this change also fixes a problem with
  too-frequent collections when the maximum-generation is set to
  zero.  to make the determination even less expensive, a running
  total of bytes in each generation is now maintained in a new
  bytes_of_generation vector, and maybe-fire-collector is no longer
  called when the collector is running.
    alloc.c, gc.c, gcwrapper.c, globals.h
- copy now copies two pairs at once only if they are in the same
  segment, which saves a few memonry references and tests and turns
  out not to reduce the number of opportunities significantly in
  tested programs.
    gc.c
- occupied_segments, first_loc, base_loc, next_loc, bytes_left,
  bytes_of_space, sweep_loc, and orig_next_loc are now indexed
  by [g][s] rather than [s][g] to improve locality in the default
  (and common) case where there are only a handful of active
  generations.
    globals.h, types.h, segment.c, gc.c, gcwrapper.c, prim5.c
- now maintaining 16-byte architectural stack alignment (if the
  incoming stack is so aligned) on all x86 platforms except
  i3nt/ti3nt.  more recent versions of gcc sometimes generate sse
  instructions that require 16-byte stack alignment.
    x86.ss

[Merge for Racket includes additional changes to combine with in-place
 marking - mflatt]
This commit is contained in:
dyb 2020-08-14 06:08:18 -06:00 committed by Matthew Flatt
parent 45a84dcb97
commit 48487ed6fb
23 changed files with 1260 additions and 768 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
racket/src/ChezScheme/LOG
View File

@ -2039,3 +2039,80 @@
strnum.ss, syntax.ss, trace.ss
- updated bullyx patches
patch*
- fixed csug copyright year substititions and changed revisiondate
to not be generated, making the csug build reproducible
newrelease csug/csug.stex
- fixed Windows build using MSYS2
c/Mf-a6nt, c/Mf-i3nt, c/Mf-ta6nt, c/Mf-ti3nt, mats/Mf-a6nt,
mats/Mf-i3nt, mats/Mf-ta6nt, mats/Mf-ti3nt
- fixed build on Linux with musl libc
expeditor.c
- extended primitive folding to primitives that return multiple
values.
cp0.ss, primdata.ss,
cp0.ms
- fix handling of calling code's address for locking around a callable
that has a u8*, u16*, or u32* argument, which could cause the
cp register copy in the thread context to be changed before
S_call_help gets it
cpnanopass.ss, schlib.c, foreign2.c, foreign.ms
- the collector now promotes objects one generation higher at a time
by default. previously, it promoted every live oldspace object to
the selected target generation, which could result in objects
prematurely skipping one or more generations and thus being
retained longer than their ages justify. the biggest cost in
terms of code complexity and performance is the recording of
pointers from older newspace objects to younger newspace objects
that could not previously occur.
gc.c, alloc.c, externs.h
- the collect procedure now takes an additional optional minimum
target generation argument to allow the new default behavior to
be overridden.
7.ss, primdata.ss,
gcwrapper.c,
7.ms, root-experr*
- added cn flag to control collect-notify
mats/Mf-base
- resweep_weak_pairs now sets sweep_loc to orig_next_loc rather than
first_loc since the latter could result in unnecessary sweeping of
existing target-generation weak pairs.
gc.c
- added set of S_child_processes[newg] to S_child_processes[oldg]
in S_do_gc code handling decreases in the maximum generation.
gcwrapper.c
- a specialized variant of the collector is used in the common case
where the max copied generation is 0, the min and max target
generations are 1, and there are no locked generation 0 objects
is now used. with the default collection parameters and no locking
of generation 0 objects, these collections account for 3/4 of all
collections.
gc.c, gc-011.c (new), gcwrapper.c, externs.h, c/Mf-base
- maybe-fire-collector no longer tries to be so precise and instead
just counts the number of generation-bytes allocated since the
last gc. suprisingly, rebuilding the s directory requires about
the same number of collections with this coarser (and less
expensive) measurement. this change also fixes a problem with
too-frequent collections when the maximum-generation is set to
zero. to make the determination even less expensive, a running
total of bytes in each generation is now maintained in a new
bytes_of_generation vector, and maybe-fire-collector is no longer
called when the collector is running.
alloc.c, gc.c, gcwrapper.c, globals.h
- copy now copies two pairs at once only if they are in the same
segment, which saves a few memonry references and tests and turns
out not to reduce the number of opportunities significantly in
tested programs.
gc.c
- occupied_segments, first_loc, base_loc, next_loc, bytes_left,
bytes_of_space, sweep_loc, and orig_next_loc are now indexed
by [g][s] rather than [s][g] to improve locality in the default
(and common) case where there are only a handful of active
generations.
globals.h, types.h, segment.c, gc.c, gcwrapper.c, prim5.c
- documented change to collect procedure
smgmt.stex, release_notes.stex
- now maintaining 16-byte architectural stack alignment (if the
incoming stack is so aligned) on all x86 platforms except
i3nt/ti3nt. more recent versions of gcc sometimes generate sse
instructions that require 16-byte stack alignment.
x86.ss

6
racket/src/ChezScheme/c/Mf-base
View File

@ -35,7 +35,7 @@ KernelLib=../boot/$m/libkernel.a
KernelLibLinkDeps=${zlibDep} ${LZ4Dep}
KernelLibLinkLibs=${zlibLib} ${LZ4Lib}
kernelsrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-ocd.c gc-oce.c\
kernelsrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-ocd.c gc-oce.c\
number.c schsig.c io.c new-io.c print.c fasl.c vfasl.c stats.c foreign.c prim.c prim5.c flushcache.c\
schlib.c thread.c expeditor.c scheme.c compress-io.c random.c
@ -68,8 +68,8 @@ ${kernelobj}: system.h types.h version.h externs.h globals.h segment.h thread.h
${kernelobj}: ${Include}/equates.h ${Include}/scheme.h
${mainobj}: ${Include}/scheme.h
${kernelobj}: ${zlibHeaderDep} ${LZ4HeaderDep}
gc-ocd.o gc-oce.o: gc.c
gc-ocd.o: ${Include}/gc-ocd.inc
gc-011.o gc-ocd.o gc-oce.o: gc.c
gc-011.o gc-ocd.o: ${Include}/gc-ocd.inc
gc-oce.o: ${Include}/gc-oce.inc
vfasl.o: ${Include}/vfasl.inc

105
racket/src/ChezScheme/c/alloc.c
View File

@ -25,13 +25,14 @@ void S_alloc_init() {
if (S_boot_time) {
/* reset the allocation tables */
for (s = 0; s <= max_real_space; s++) {
for (g = 0; g <= static_generation; g++) {
S_G.base_loc[s][g] = FIX(0);
S_G.first_loc[s][g] = FIX(0);
S_G.next_loc[s][g] = FIX(0);
S_G.bytes_left[s][g] = 0;
S_G.bytes_of_space[s][g] = 0;
for (g = 0; g <= static_generation; g++) {
S_G.bytes_of_generation[g] = 0;
for (s = 0; s <= max_real_space; s++) {
S_G.base_loc[g][s] = FIX(0);
S_G.first_loc[g][s] = FIX(0);
S_G.next_loc[g][s] = FIX(0);
S_G.bytes_left[g][s] = 0;
S_G.bytes_of_space[g][s] = 0;
}
}
@ -41,6 +42,7 @@ void S_alloc_init() {
}
S_G.collect_trip_bytes = default_collect_trip_bytes;
S_G.g0_bytes_after_last_gc = 0;
/* set to final value in prim.c when known */
S_protect(&S_G.nonprocedure_code);
@ -149,11 +151,12 @@ ptr S_compute_bytes_allocated(xg, xs) ptr xg; ptr xs; {
while (g <= gmax) {
n += S_G.bytesof[g][countof_phantom];
for (s = smin; s <= smax; s++) {
ptr next_loc = S_G.next_loc[g][s];
/* add in bytes previously recorded */
n += S_G.bytes_of_space[s][g];
n += S_G.bytes_of_space[g][s];
/* add in bytes in active segments */
if (S_G.next_loc[s][g] != FIX(0))
n += (uptr)S_G.next_loc[s][g] - (uptr)S_G.base_loc[s][g];
if (next_loc != FIX(0))
n += (uptr)next_loc - (uptr)S_G.base_loc[g][s];
}
if (g == S_G.max_nonstatic_generation)
g = static_generation;
@ -173,29 +176,7 @@ ptr S_bytes_finalized() {
}
static void maybe_fire_collector() {
ISPC s;
uptr bytes, fudge;
bytes = S_G.bytesof[0][countof_phantom];
for (s = 0; s <= max_real_space; s += 1) {
/* bytes already accounted for */
bytes += S_G.bytes_of_space[s][0];
/* bytes in current block of segments */
if (S_G.next_loc[s][0] != FIX(0))
bytes += (uptr)S_G.next_loc[s][0] - (uptr)S_G.base_loc[s][0];
}
/* arbitrary fudge factor to account for space we may not be using yet
arbitrary because:
- we assume each thread has not yet used half it's allocation area
- we assume each thread has not yet used half its stack
- some threads' stacks may not be as much as the default size
*/
fudge = (default_stack_size / 2) + S_nthreads * (bytes_per_segment / 2);
bytes = bytes > fudge ? bytes - fudge : 0;
if (bytes >= S_G.collect_trip_bytes)
if ((S_G.bytes_of_generation[0] + S_G.bytesof[0][countof_phantom]) - S_G.g0_bytes_after_last_gc >= S_G.collect_trip_bytes)
S_fire_collector();
}
@ -228,22 +209,24 @@ ptr S_find_more_room(s, g, n, old) ISPC s; IGEN g; iptr n; ptr old; {
if (old == FIX(0)) {
/* first object of this space */
S_G.first_loc[s][g] = new;
S_G.first_loc[g][s] = new;
} else {
uptr bytes = (uptr)old - (uptr)S_G.base_loc[g][s];
/* increment bytes_allocated by the closed-off partial segment */
S_G.bytes_of_space[s][g] += (uptr)old - (uptr)S_G.base_loc[s][g];
S_G.bytes_of_space[g][s] += bytes;
S_G.bytes_of_generation[g] += bytes;
/* lay down an end-of-segment marker */
*(ptr*)TO_VOIDP(old) = forward_marker;
*((ptr*)TO_VOIDP(old) + 1) = new;
}
/* base address of current block of segments to track amount of allocation */
S_G.base_loc[s][g] = new;
S_G.base_loc[g][s] = new;
S_G.next_loc[s][g] = (ptr)((uptr)new + n);
S_G.bytes_left[s][g] = (nsegs * bytes_per_segment - n) - 2 * ptr_bytes;
S_G.next_loc[g][s] = (ptr)((uptr)new + n);
S_G.bytes_left[g][s] = (nsegs * bytes_per_segment - n) - 2 * ptr_bytes;
if (g == 0) maybe_fire_collector();
if (g == 0 && S_pants_down == 1) maybe_fire_collector();
S_pants_down -= 1;
return new;
@ -274,9 +257,10 @@ void S_reset_allocation_pointer(tc) ptr tc; {
seg = S_find_segments(space_new, 0, 1);
*/
S_G.bytes_of_space[space_new][0] += bytes_per_segment;
S_G.bytes_of_space[0][space_new] += bytes_per_segment;
S_G.bytes_of_generation[0] += bytes_per_segment;
maybe_fire_collector();
if (S_pants_down == 1) maybe_fire_collector();
AP(tc) = build_ptr(seg, 0);
REAL_EAP(tc) = EAP(tc) = (ptr)((uptr)AP(tc) + bytes_per_segment);
@ -285,22 +269,22 @@ void S_reset_allocation_pointer(tc) ptr tc; {
}
FORCEINLINE void mark_segment_dirty(seginfo *si, IGEN from_g) {
IGEN to_g = si->min_dirty_byte;
if (to_g != 0) {
FORCEINLINE void mark_segment_dirty(seginfo *si, IGEN from_g, IGEN to_g) {
IGEN old_to_g = si->min_dirty_byte;
if (to_g < old_to_g) {
seginfo **pointer_to_first, *oldfirst;
if (to_g != 0xff) {
if (old_to_g != 0xff) {
seginfo *next = si->dirty_next, **prev = si->dirty_prev;
/* presently on some other list, so remove */
*prev = next;
if (next != NULL) next->dirty_prev = prev;
}
oldfirst = *(pointer_to_first = &DirtySegments(from_g, 0));
oldfirst = *(pointer_to_first = &DirtySegments(from_g, to_g));
*pointer_to_first = si;
si->dirty_prev = pointer_to_first;
si->dirty_next = oldfirst;
if (oldfirst != NULL) oldfirst->dirty_prev = &si->dirty_next;
si->min_dirty_byte = 0;
si->min_dirty_byte = to_g;
}
}
@ -319,12 +303,23 @@ void S_dirty_set(ptr *loc, ptr x) {
IGEN from_g = si->generation;
if (from_g != 0) {
si->dirty_bytes[((uptr)TO_PTR(loc) >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0;
mark_segment_dirty(si, from_g);
mark_segment_dirty(si, from_g, 0);
}
}
}
}
void S_mark_card_dirty(uptr card, IGEN to_g) {
uptr loc = card << card_offset_bits;
uptr seg = addr_get_segment(loc);
seginfo *si = SegInfo(seg);
uptr cardno = card & ((1 << segment_card_offset_bits) - 1);
if (to_g < si->dirty_bytes[cardno]) {
si->dirty_bytes[cardno] = to_g;
mark_segment_dirty(si, si->generation, to_g);
}
}
/* scan remembered set from P to ENDP, transfering to dirty vector */
void S_scan_dirty(ptr *p, ptr *endp) {
uptr this, last;
@ -347,7 +342,7 @@ void S_scan_dirty(ptr *p, ptr *endp) {
IGEN from_g = si->generation;
if (from_g != 0) {
si->dirty_bytes[((uptr)loc >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0;
if (this >> segment_card_offset_bits != last >> segment_card_offset_bits) mark_segment_dirty(si, from_g);
if (this >> segment_card_offset_bits != last >> segment_card_offset_bits) mark_segment_dirty(si, from_g, 0);
}
last = this;
}
@ -376,7 +371,9 @@ void S_scan_remembered_set() {
AP(tc) = (ptr)ap;
EAP(tc) = (ptr)eap;
} else {
S_G.bytes_of_space[space_new][0] -= eap - ap;
uptr bytes = eap - ap;
S_G.bytes_of_space[0][space_new] -= bytes;
S_G.bytes_of_generation[0] -= bytes;
S_reset_allocation_pointer(tc);
}
@ -420,7 +417,9 @@ ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) {
AP(tc) = (ptr)ap;
EAP(tc) = (ptr)eap;
} else {
S_G.bytes_of_space[space_new][0] -= eap - ap;
uptr bytes = eap - ap;
S_G.bytes_of_space[0][space_new] -= bytes;
S_G.bytes_of_generation[0] -= bytes;
S_reset_allocation_pointer(tc);
}
} else if (eap - ap > alloc_waste_maximum) {
@ -428,7 +427,9 @@ ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) {
EAP(tc) = (ptr)eap;
find_room(space_new, 0, type, size, x);
} else {
S_G.bytes_of_space[space_new][0] -= eap - ap;
uptr bytes = eap - ap;
S_G.bytes_of_space[0][space_new] -= bytes;
S_G.bytes_of_generation[0] -= bytes;
S_reset_allocation_pointer(tc);
ap = (uptr)AP(tc);
if (size + alloc_waste_maximum <= (uptr)EAP(tc) - ap) {

14
racket/src/ChezScheme/c/externs.h
View File

@ -67,6 +67,7 @@ extern ptr S_compute_bytes_allocated PROTO((ptr xg, ptr xs));
extern ptr S_bytes_finalized PROTO(());
extern ptr S_find_more_room PROTO((ISPC s, IGEN g, iptr n, ptr old));
extern void S_dirty_set PROTO((ptr *loc, ptr x));
extern void S_mark_card_dirty PROTO((uptr card, IGEN to_g));
extern void S_scan_dirty PROTO((ptr *p, ptr *endp));
extern void S_scan_remembered_set PROTO((void));
extern void S_get_more_room PROTO((void));
@ -147,8 +148,8 @@ extern void S_gc_init PROTO((void));
extern void S_register_child_process PROTO((INT child));
#endif /* WIN32 */
extern void S_fixup_counts PROTO((ptr counts));
extern ptr S_do_gc PROTO((IGEN g, IGEN gtarget, ptr count_roots));
extern ptr S_gc PROTO((ptr tc, IGEN mcg, IGEN tg, ptr count_roots));
extern ptr S_do_gc PROTO((IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots));
extern ptr S_gc PROTO((ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots));
extern void S_gc_init PROTO((void));
extern void S_set_maxgen PROTO((IGEN g));
extern IGEN S_maxgen PROTO((void));
@ -156,7 +157,6 @@ extern void S_set_minfreegen PROTO((IGEN g));
extern IGEN S_minfreegen PROTO((void));
extern void S_set_minmarkgen PROTO((IGEN g));
extern IGEN S_minmarkgen PROTO((void));
extern ptr S_locked_objects PROTO((void));
#ifndef WIN32
extern void S_register_child_process PROTO((INT child));
#endif /* WIN32 */
@ -168,15 +168,19 @@ extern void S_set_enable_object_backreferences PROTO((IBOOL eoc));
extern ptr S_object_backreferences PROTO((void));
extern void S_immobilize_object PROTO((ptr v));
extern void S_mobilize_object PROTO((ptr v));
extern ptr S_locked_objects PROTO((void));
extern ptr S_unregister_guardian PROTO((ptr tconc));
extern void S_compact_heap PROTO((void));
extern void S_check_heap PROTO((IBOOL aftergc, IGEN target_gen));
/* gc-011.c */
extern void S_gc_011 PROTO((ptr tc));
/* gc-ocd.c */
extern ptr S_gc_ocd PROTO((ptr tc, IGEN mcg, IGEN tg, ptr count_roots));
extern ptr S_gc_ocd PROTO((ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots));
/* gc-oce.c */
extern ptr S_gc_oce PROTO((ptr tc, IGEN mcg, IGEN tg, ptr count_roots));
extern ptr S_gc_oce PROTO((ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots));
extern ptr S_count_size_increments PROTO((ptr ls, IGEN generation));
/* intern.c */

26
racket/src/ChezScheme/c/gc-011.c Normal file
View File

@ -0,0 +1,26 @@
/* gc-011.c
* Copyright 1984-2020 Cisco Systems, Inc.
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
*/
#define GCENTRY S_gc_011_entry
#define MAX_CG 0
#define MIN_TG 1
#define MAX_TG 1
#define NO_LOCKED_OLDSPACE_OBJECTS
#include "gc.c"
void S_gc_011(ptr tc) {
(void)S_gc_011_entry(tc, Sfalse);
}

10
racket/src/ChezScheme/c/gc-ocd.c
View File

@ -14,5 +14,13 @@
* limitations under the License.
*/
#define GCENTRY S_gc_ocd
#define GCENTRY S_gc_ocd_entry
#include "gc.c"
ptr S_gc_ocd(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) {
MAX_CG = max_cg;
MIN_TG = min_tg;
MAX_TG = max_tg;
return S_gc_ocd_entry(tc, count_roots);
}

10
racket/src/ChezScheme/c/gc-oce.c
View File

@ -14,8 +14,16 @@
* limitations under the License.
*/
#define GCENTRY S_gc_oce
#define GCENTRY S_gc_oce_entry
#define ENABLE_OBJECT_COUNTS
#define ENABLE_BACKREFERENCE
#define ENABLE_MEASURE
#include "gc.c"
ptr S_gc_oce(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) {
MAX_CG = max_cg;
MIN_TG = min_tg;
MAX_TG = max_tg;
return S_gc_oce_entry(tc, count_roots);
}

961
racket/src/ChezScheme/c/gc.c
View File

File diff suppressed because it is too large Load Diff

52
racket/src/ChezScheme/c/gcwrapper.c
View File

@ -473,7 +473,7 @@ void Scompact_heap() {
IBOOL eoc = S_G.enable_object_counts;
S_pants_down += 1;
S_G.enable_object_counts = 1;
S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation, Sfalse);
S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation, static_generation, Sfalse);
S_G.enable_object_counts = eoc;
S_pants_down -= 1;
}
@ -584,7 +584,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
for (s = 0; s <= max_real_space; s += 1) {
seginfo *si;
for (g = 0; g <= S_G.max_nonstatic_generation; INCRGEN(g)) {
for (si = S_G.occupied_segments[s][g]; si != NULL; si = si->next) {
for (si = S_G.occupied_segments[g][s]; si != NULL; si = si->next) {
if (si->generation != g) {
S_checkheap_errors += 1;
printf("!!! segment in wrong occupied_segments list\n");
@ -592,7 +592,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
nonstatic_segments += 1;
}
}
for (si = S_G.occupied_segments[s][static_generation]; si != NULL; si = si->next) {
for (si = S_G.occupied_segments[static_generation][s]; si != NULL; si = si->next) {
static_segments += 1;
}
}
@ -647,7 +647,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
|| 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 */
nl = TO_VOIDP(S_G.next_loc[s][g]);
nl = TO_VOIDP(S_G.next_loc[g][s]);
/* check for dangling references */
pp1 = TO_VOIDP(build_ptr(seg, 0));
@ -819,7 +819,7 @@ static void check_dirty_space(ISPC s) {
IGEN from_g, to_g, min_to_g; INT d; seginfo *si;
for (from_g = 0; from_g <= static_generation; from_g += 1) {
for (si = S_G.occupied_segments[s][from_g]; si != NULL; si = si->next) {
for (si = S_G.occupied_segments[from_g][s]; si != NULL; si = si->next) {
min_to_g = 0xff;
for (d = 0; d < cards_per_segment; d += 1) {
to_g = si->dirty_bytes[d];
@ -933,7 +933,7 @@ void S_fixup_counts(ptr counts) {
RTDCOUNTSTIMESTAMP(counts) = S_G.gctimestamp[0];
}
ptr S_do_gc(IGEN mcg, IGEN tg, ptr count_roots) {
ptr S_do_gc(IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) {
ptr tc = get_thread_context();
ptr code, result;
@ -949,22 +949,23 @@ ptr S_do_gc(IGEN mcg, IGEN tg, ptr count_roots) {
S_G.max_nonstatic_generation = S_G.new_max_nonstatic_generation;
}
if (tg == mcg && mcg == S_G.new_max_nonstatic_generation && mcg < S_G.max_nonstatic_generation) {
if (max_tg == max_cg && max_cg == S_G.new_max_nonstatic_generation && max_cg < S_G.max_nonstatic_generation) {
IGEN new_g, old_g, from_g, to_g; ISPC s; seginfo *si, *nextsi, *tail;
/* reducing max_nonstatic_generation */
new_g = S_G.new_max_nonstatic_generation;
old_g = S_G.max_nonstatic_generation;
/* first, collect everything to old_g */
result = S_gc(tc, old_g, old_g, count_roots);
/* first, collect everything to old_g, ignoring min_tg */
result = S_gc(tc, old_g, old_g, old_g, count_roots);
/* now transfer old_g info to new_g, and clear old_g info */
S_G.bytes_of_generation[new_g] = S_G.bytes_of_generation[old_g]; S_G.bytes_of_generation[old_g] = 0;
for (s = 0; s <= max_real_space; s += 1) {
S_G.first_loc[s][new_g] = S_G.first_loc[s][old_g]; S_G.first_loc[s][old_g] = FIX(0);
S_G.base_loc[s][new_g] = S_G.base_loc[s][old_g]; S_G.base_loc[s][old_g] = FIX(0);
S_G.next_loc[s][new_g] = S_G.next_loc[s][old_g]; S_G.next_loc[s][old_g] = FIX(0);
S_G.bytes_left[s][new_g] = S_G.bytes_left[s][old_g]; S_G.bytes_left[s][old_g] = 0;
S_G.bytes_of_space[s][new_g] = S_G.bytes_of_space[s][old_g]; S_G.bytes_of_space[s][old_g] = 0;
S_G.occupied_segments[s][new_g] = S_G.occupied_segments[s][old_g]; S_G.occupied_segments[s][old_g] = NULL;
for (si = S_G.occupied_segments[s][new_g]; si != NULL; si = si->next) {
S_G.first_loc[new_g][s] = S_G.first_loc[old_g][s]; S_G.first_loc[old_g][s] = FIX(0);
S_G.base_loc[new_g][s] = S_G.base_loc[old_g][s]; S_G.base_loc[old_g][s] = FIX(0);
S_G.next_loc[new_g][s] = S_G.next_loc[old_g][s]; S_G.next_loc[old_g][s] = FIX(0);
S_G.bytes_left[new_g][s] = S_G.bytes_left[old_g][s]; S_G.bytes_left[old_g][s] = 0;
S_G.bytes_of_space[new_g][s] = S_G.bytes_of_space[old_g][s]; S_G.bytes_of_space[old_g][s] = 0;
S_G.occupied_segments[new_g][s] = S_G.occupied_segments[old_g][s]; S_G.occupied_segments[old_g][s] = NULL;
for (si = S_G.occupied_segments[new_g][s]; si != NULL; si = si->next) {
si->generation = new_g;
}
}
@ -988,6 +989,7 @@ ptr S_do_gc(IGEN mcg, IGEN tg, ptr count_roots) {
RTDCOUNTSIT(counts, new_g) = RTDCOUNTSIT(counts, old_g); RTDCOUNTSIT(counts, old_g) = 0;
}
}
S_child_processes[new_g] = S_child_processes[old_g];
/* change old_g dirty bytes in static generation to new_g; splice list of old_g
seginfos onto front of new_g seginfos */
@ -1039,25 +1041,29 @@ ptr S_do_gc(IGEN mcg, IGEN tg, ptr count_roots) {
S_G.min_free_gen = S_G.new_min_free_gen;
S_G.max_nonstatic_generation = new_g;
} else {
result = S_gc(tc, mcg, tg, count_roots);
result = S_gc(tc, max_cg, min_tg, max_tg, count_roots);
}
S_pants_down -= 1;
/* eagerly give collecting thread, the only one guaranteed to be
active, a fresh allocation area. the other threads have to trap
to get_more_room if and when they awake and try to allocate */
S_reset_allocation_pointer(tc);
S_pants_down -= 1;
Sunlock_object(code);
return result;
}
ptr S_gc(ptr tc, IGEN mcg, IGEN tg, ptr count_roots) {
if (tg == static_generation
ptr S_gc(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) {
if (min_tg == static_generation
|| S_G.enable_object_counts || S_G.enable_object_backreferences
|| (count_roots != Sfalse))
return S_gc_oce(tc, mcg, tg, count_roots);
else
return S_gc_ocd(tc, mcg, tg, Sfalse);
return S_gc_oce(tc, max_cg, min_tg, max_tg, count_roots);
else if (max_cg == 0 && min_tg == 1 && max_tg == 1 && S_G.locked_objects[0] == Snil) {
S_gc_011(tc);
return Sfalse;
} else
return S_gc_ocd(tc, max_cg, min_tg, max_tg, Sfalse);
}

14
racket/src/ChezScheme/c/globals.h
View File

@ -89,18 +89,20 @@ EXTERN struct S_G_struct {
ptr threadno;
/* segment.c */
seginfo *occupied_segments[max_real_space+1][static_generation+1];
seginfo *occupied_segments[static_generation+1][max_real_space+1];
uptr number_of_nonstatic_segments;
uptr number_of_empty_segments;
/* alloc.c */
ptr *protected[max_protected];
uptr protect_next;
ptr first_loc[max_real_space+1][static_generation+1];
ptr base_loc[max_real_space+1][static_generation+1];
ptr next_loc[max_real_space+1][static_generation+1];
iptr bytes_left[max_real_space+1][static_generation+1];
uptr bytes_of_space[max_real_space+1][static_generation+1];
ptr first_loc[static_generation+1][max_real_space+1];
ptr base_loc[static_generation+1][max_real_space+1];
ptr next_loc[static_generation+1][max_real_space+1];
iptr bytes_left[static_generation+1][max_real_space+1];
uptr bytes_of_space[static_generation+1][max_real_space+1];
uptr bytes_of_generation[static_generation+1];
uptr g0_bytes_after_last_gc;
uptr collect_trip_bytes;
ptr nonprocedure_code;
ptr null_string;

64
racket/src/ChezScheme/c/prim5.c
View File

@ -395,8 +395,8 @@ static void s_show_chunks(FILE *out, ptr sorted_chunks) {
#define INCRGEN(g) (g = g == S_G.max_nonstatic_generation ? static_generation : g+1)
static void s_showalloc(IBOOL show_dump, const char *outfn) {
FILE *out;
iptr count[space_total+1][generation_total+1];
uptr bytes[space_total+1][generation_total+1];
iptr count[generation_total+1][space_total+1];
uptr bytes[generation_total+1][space_total+1];
int i, column_size[generation_total+1];
char fmtbuf[FMTBUFSIZE];
static char *spacename[space_total+1] = { alloc_space_names, "bogus", "total" };
@ -427,42 +427,42 @@ static void s_showalloc(IBOOL show_dump, const char *outfn) {
}
}
}
for (s = 0; s <= space_total; s++)
for (g = 0; g <= generation_total; INCRGEN(g))
count[s][g] = bytes[s][g] = 0;
for (g = 0; g <= generation_total; INCRGEN(g))
for (s = 0; s <= space_total; s++)
count[g][s] = bytes[g][s] = 0;
for (s = 0; s <= max_real_space; s++) {
for (g = 0; g <= static_generation; INCRGEN(g)) {
for (g = 0; g <= static_generation; INCRGEN(g)) {
for (s = 0; s <= max_real_space; s++) {
/* add in bytes previously recorded */
bytes[s][g] += S_G.bytes_of_space[s][g];
bytes[g][s] += S_G.bytes_of_space[g][s];
/* add in bytes in active segments */
if (S_G.next_loc[s][g] != FIX(0))
bytes[s][g] += (uptr)S_G.next_loc[s][g] - (uptr)S_G.base_loc[s][g];
if (S_G.next_loc[g][s] != FIX(0))
bytes[g][s] += (uptr)S_G.next_loc[g][s] - (uptr)S_G.base_loc[g][s];
}
}
for (s = 0; s <= max_real_space; s++) {
for (g = 0; g <= static_generation; INCRGEN(g)) {
for (si = S_G.occupied_segments[s][g]; si != NULL; si = si->next) {
count[s][g] += 1;
for (g = 0; g <= static_generation; INCRGEN(g)) {
for (s = 0; s <= max_real_space; s++) {
for (si = S_G.occupied_segments[g][s]; si != NULL; si = si->next) {
count[g][s] += 1;
}
}
}
for (s = 0; s < space_total; s++) {
for (g = 0; g < generation_total; INCRGEN(g)) {
count[space_total][g] += count[s][g];
count[s][generation_total] += count[s][g];
count[space_total][generation_total] += count[s][g];
bytes[space_total][g] += bytes[s][g];
bytes[s][generation_total] += bytes[s][g];
bytes[space_total][generation_total] += bytes[s][g];
for (g = 0; g < generation_total; INCRGEN(g)) {
for (s = 0; s < space_total; s++) {
count[g][space_total] += count[g][s];
count[generation_total][s] += count[g][s];
count[generation_total][space_total] += count[g][s];
bytes[g][space_total] += bytes[g][s];
bytes[generation_total][s] += bytes[g][s];
bytes[generation_total][space_total] += bytes[g][s];
}
}
for (g = 0; g <= generation_total; INCRGEN(g)) {
if (count[space_total][g] != 0) {
int n = 1 + snprintf(fmtbuf, FMTBUFSIZE, ""Ptd"", (ptrdiff_t)count[space_total][g]);
if (count[g][space_total] != 0) {
int n = 1 + snprintf(fmtbuf, FMTBUFSIZE, ""Ptd"", (ptrdiff_t)count[g][space_total]);
column_size[g] = n < 8 ? 8 : n;
}
}
@ -470,7 +470,7 @@ static void s_showalloc(IBOOL show_dump, const char *outfn) {
fprintf(out, "Segments per space & generation:\n\n");
fprintf(out, "%8s", "");
for (g = 0; g <= generation_total; INCRGEN(g)) {
if (count[space_total][g] != 0) {
if (count[g][space_total] != 0) {
if (g == generation_total) {
/* coverity[uninit_use] */
snprintf(fmtbuf, FMTBUFSIZE, "%%%ds", column_size[g]);
@ -489,25 +489,25 @@ static void s_showalloc(IBOOL show_dump, const char *outfn) {
fprintf(out, "\n");
for (s = 0; s <= space_total; s++) {
if (s != space_empty) {
if (count[s][generation_total] != 0) {
if (count[generation_total][s] != 0) {
fprintf(out, "%7s:", spacename[s]);
for (g = 0; g <= generation_total; INCRGEN(g)) {
if (count[space_total][g] != 0) {
if (count[g][space_total] != 0) {
/* coverity[uninit_use] */
snprintf(fmtbuf, FMTBUFSIZE, "%%%dtd", column_size[g]);
fprintf(out, fmtbuf, (ptrdiff_t)(count[s][g]));
fprintf(out, fmtbuf, (ptrdiff_t)(count[g][s]));
}
}
fprintf(out, "\n");
fprintf(out, "%8s", "");
for (g = 0; g <= generation_total; INCRGEN(g)) {
if (count[space_total][g] != 0) {
if (count[s][g] != 0 && s <= max_real_space) {
if (count[g][space_total] != 0) {
if (count[g][s] != 0 && s <= max_real_space) {
/* coverity[uninit_use] */
snprintf(fmtbuf, FMTBUFSIZE, "%%%dd%%%%", column_size[g] - 1);
fprintf(out, fmtbuf,
(int)(((double)bytes[s][g] /
((double)count[s][g] * bytes_per_segment)) * 100.0));
(int)(((double)bytes[g][s] /
((double)count[g][s] * bytes_per_segment)) * 100.0));
} else {
/* coverity[uninit_use] */
snprintf(fmtbuf, FMTBUFSIZE, "%%%ds", column_size[g]);

47
racket/src/ChezScheme/c/segment.c
View File

@ -36,6 +36,7 @@ Low-level Memory management strategy:
#include "sort.h"
#include <sys/types.h>
static void out_of_memory PROTO((void));
static void initialize_seginfo PROTO((seginfo *si, ISPC s, IGEN g));
static seginfo *allocate_segments PROTO((uptr nreq));
static void expand_segment_table PROTO((uptr base, uptr end, seginfo *si));
@ -51,9 +52,9 @@ void S_segment_init() {
S_chunks_full = NULL;
for (i = PARTIAL_CHUNK_POOLS; i >= 0; i -= 1) S_chunks[i] = NULL;
for (s = 0; s <= max_real_space; s++) {
for (g = 0; g <= static_generation; g++) {
S_G.occupied_segments[s][g] = NULL;
for (g = 0; g <= static_generation; g++) {
for (s = 0; s <= max_real_space; s++) {
S_G.occupied_segments[g][s] = NULL;
}
}
S_G.number_of_nonstatic_segments = 0;
@ -72,14 +73,16 @@ void S_segment_init() {
static uptr membytes = 0;
static uptr maxmembytes = 0;
static void out_of_memory(void) {
(void) fprintf(stderr,"out of memory\n");
S_abnormal_exit();
}
#if defined(USE_MALLOC)
void *S_getmem(iptr bytes, IBOOL zerofill) {
void *addr;
if ((addr = malloc(bytes)) == (void *)0) {
(void) fprintf(stderr,"out of memory\n");
S_abnormal_exit();
}
if ((addr = malloc(bytes)) == (void *)0) out_of_memory();
debug(printf("getmem(%p) -> %p\n", bytes, addr))
if ((membytes += bytes) > maxmembytes) maxmembytes = membytes;
@ -100,19 +103,13 @@ void *S_getmem(iptr bytes, IBOOL zerofill) {
void *addr;
if ((uptr)bytes < S_pagesize) {
if ((addr = malloc(bytes)) == (void *)0) {
(void) fprintf(stderr,"out of memory\n");
S_abnormal_exit();
}
if ((addr = malloc(bytes)) == (void *)0) out_of_memory();
debug(printf("getmem malloc(%p) -> %p\n", bytes, addr))
if ((membytes += bytes) > maxmembytes) maxmembytes = membytes;
if (zerofill) memset(addr, 0, bytes);
} else {
uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n);
if ((addr = VirtualAlloc((void *)0, (SIZE_T)p_bytes, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == (void *)0) {
(void) fprintf(stderr, "out of memory\n");
S_abnormal_exit();
}
if ((addr = VirtualAlloc((void *)0, (SIZE_T)p_bytes, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == (void *)0) out_of_memory();
if ((membytes += p_bytes) > maxmembytes) maxmembytes = membytes;
debug(printf("getmem VirtualAlloc(%p => %p) -> %p\n", bytes, p_bytes, addr))
}
@ -143,10 +140,7 @@ void *S_getmem(iptr bytes, IBOOL zerofill) {
void *addr;
if ((uptr)bytes < S_pagesize) {
if ((addr = malloc(bytes)) == (void *)0) {
(void) fprintf(stderr,"out of memory\n");
S_abnormal_exit();
}
if ((addr = malloc(bytes)) == (void *)0) out_of_memory();
debug(printf("getmem malloc(%p) -> %p\n", bytes, addr))
if ((membytes += bytes) > maxmembytes) maxmembytes = membytes;
if (zerofill) memset(addr, 0, bytes);
@ -158,8 +152,7 @@ void *S_getmem(iptr bytes, IBOOL zerofill) {
if ((addr = mmap(NULL, p_bytes, PROT_EXEC|PROT_WRITE|PROT_READ, MAP_PRIVATE|MAP_ANONYMOUS|MAP_32BIT, -1, 0)) == (void *)-1) {
#endif
if ((addr = mmap(NULL, p_bytes, PROT_EXEC|PROT_WRITE|PROT_READ, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0)) == (void *)-1) {
(void) fprintf(stderr,"out of memory\n");
S_abnormal_exit();
out_of_memory();
debug(printf("getmem mmap(%p) -> %p\n", bytes, addr))
}
#ifdef MAP_32BIT
@ -284,8 +277,8 @@ iptr S_find_segments(s, g, n) ISPC s; IGEN g; iptr n; {
chunk->nused_segs += 1;
initialize_seginfo(si, s, g);
si->next = S_G.occupied_segments[s][g];
S_G.occupied_segments[s][g] = si;
si->next = S_G.occupied_segments[g][s];
S_G.occupied_segments[g][s] = si;
S_G.number_of_empty_segments -= 1;
return si->number;
}
@ -318,8 +311,8 @@ iptr S_find_segments(s, g, n) ISPC s; IGEN g; iptr n; {
S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]);
}
chunk->nused_segs += n;
nextsi->next = S_G.occupied_segments[s][g];
S_G.occupied_segments[s][g] = si;
nextsi->next = S_G.occupied_segments[g][s];
S_G.occupied_segments[g][s] = si;
for (j = n, nextsi = si; j > 0; j -= 1, nextsi = nextsi->next) {
initialize_seginfo(nextsi, s, g);
}
@ -343,8 +336,8 @@ iptr S_find_segments(s, g, n) ISPC s; IGEN g; iptr n; {
for (nextsi = si; n > 0; n -= 1, nextsi += 1) {
initialize_seginfo(nextsi, s, g);
/* add segment to appropriate list of occupied segments */
nextsi->next = S_G.occupied_segments[s][g];
S_G.occupied_segments[s][g] = nextsi;
nextsi->next = S_G.occupied_segments[g][s];
S_G.occupied_segments[g][s] = nextsi;
}
return si->number;
}

6
racket/src/ChezScheme/c/types.h
View File

@ -82,9 +82,9 @@ typedef int IFASLCODE; /* fasl type codes */
* no space is left in the current segment. n is assumed to be
* an integral multiple of the object alignment. */
#define find_room_T(s, g, t, n, T, x) { \
ptr X = S_G.next_loc[s][g];\
S_G.next_loc[s][g] = (ptr)((uptr)X + (n));\
if ((S_G.bytes_left[s][g] -= (n)) < 0) X = S_find_more_room(s, g, n, X);\
ptr X = S_G.next_loc[g][s];\
S_G.next_loc[g][s] = (ptr)((uptr)X + (n));\
if ((S_G.bytes_left[g][s] -= (n)) < 0) X = S_find_more_room(s, g, n, X);\
(x) = T(TYPE(X, t)); \
}

145
racket/src/ChezScheme/csug/smgmt.stex
View File

@ -18,8 +18,8 @@ procedures that may be used to control its operation.
\section{Garbage Collection\label{SECTSMGMTGC}}
Scheme objects such as pairs, strings, and procedures are
never explicitly deallocated by a Scheme program.
Scheme objects such as pairs, strings, procedures, and user-defined
records are never explicitly deallocated by a Scheme program.
Instead, the \index{storage management}storage management system
automatically reclaims the
storage associated with an object once it proves the object is no longer
@ -44,7 +44,8 @@ The collect-request handler can be redefined by changing the value of the
parameter
\index{\scheme{collect-request-handler}}\scheme{collect-request-handler}.
A program can also cause a collection to occur between collect-request
interrupts by calling \scheme{collect} directly.
interrupts by calling \scheme{collect} directly either without or with
arguments.
{\ChezScheme}'s collector is a \emph{generation-based} collector.
It segregates objects based on their age (roughly speaking, the
@ -59,64 +60,56 @@ which storage is never reclaimed.
Objects are placed into the static generation only
when a heap is compacted (see
\index{\scheme{Scompact_heap}}\scheme{Scompact_heap} in
Section~\ref{SECTFOREIGNCLIB}) or when the target-generation argument to
\index{\scheme{collect}}\scheme{collect} is the symbol \scheme{static}.
Section~\ref{SECTFOREIGNCLIB}) or when an explicitly specified
target-generation is the symbol \scheme{static}.
This is primarily useful after an application's permanent code and data
structures have been loaded and initialized, to reduce the overhead of
subsequent collections.
Nonstatic generations are numbered starting at zero for the youngest
generation up through the current value of
\index{\scheme{collect-maximum-generation}}\scheme{collect-maximum-generation}.
The storage manager places newly allocated objects into generation 0.
During a generation 0 collection, objects in generation 0 that survive the
collection move, by default, to generation 1.
Similarly, during a generation 1 collection, objects in generations 0 and
1 that survive move to generation 2, and so on.
During the collection of the maximum nonstatic collection, all surviving
nonstatic objects move (possibly back) into the maximum nonstatic
generation.
With this mechanism, it is possible for an object to skip one or more
generations, but this is not likely to happen to many objects, and if the
objects become inaccessible, their storage is reclaimed eventually.
When \scheme{collect} is invoked without arguments, generation 0
objects that survive collection move to generation 1, generation 1
objects that survive move to generation 2, and so on, except that
objects are never moved past the maximum nonstatic generation.
Objects in the maximum nonstatic generation are collected back into
the maximum nonstatic generation.
While generation 0 is collected during each collection, older
generations are collected less frequently.
An internal counter, gc-trip, is maintained to control when each
generation is collected.
Each time \scheme{collect} is called without arguments (as from the default
collect-request handler), gc-trip is incremented by one.
With a collect-generation radix of $r$, the collected generation
collect-request handler), gc-trip is incremented by one, and the set of
generations to be collected is determined from the current value of
gc-trip and the value of
\index{\scheme{collect-generation-radix}}\scheme{collect-generation-radix}:
with a collect-generation radix of $r$, the maximum collected generation
is the highest numbered generation $g$ for which gc-trip is a
multiple of $r^g$.
If \scheme{collect-generation-radix} is set to 4, the system thus
collects generation 0 every time, generation 1 every 4 times, generation 2
every 16 times, and so on.
collects generation 0 every time, generation 1 every 4 times,
generation 2 every 16 times, and so on.
Each time \scheme{collect} is called with a single generation argument $g$,
generation $g$ is collected and
gc-trip is advanced to the next $r^g$ boundary, but not past the next
$r^{g+1}$ boundary, where $r$ is again the
When \scheme{collect} is invoked with arguments, the generations to be
collected and their target generations are determined by the arguments.
In addition, the first argument \var{cg} affects the value of gc-trip;
that is, gc-trip is advanced to the next $r^{cg}$ boundary, but
not past the next $r^{cg+1}$ boundary, where $r$ is the
value of \scheme{collect-generation-radix}.
If \scheme{collect} is called with a second generation argument,
$tg$, $tg$ determines the target generation.
When $g$ is the maximum nonstatic generation, $tg$ must be
$g$ or the symbol \scheme{static}.
Otherwise, $tg$ must be $g$ or $g+1$.
When the target generation is the symbol \scheme{static}, all data in
the nonstatic generations are moved to the static generation.
Objects in the static generation are never collected.
This is primarily useful after an application's permanent code and data
structures have been loaded and initialized, to reduce the overhead of
subsequent collections.
It is possible to make substantial adjustments in the collector's behavior
by setting the parameters described in this section.
It is even possible to completely override the collector's default strategy for
determining when each generation is collected by redefining the
collect-request handler to call \scheme{collect} with explicit $g$ and
$tg$ arguments.
For example, the programmer can redefine the handler to treat the maximum
nonstatic generation as a static generation over a long period of time
by calling \scheme{collect} with explicit $g$ and $tg$ arguments
that are never equal to the maximum nonstatic generation during that
period of time.
collect-request handler to call \scheme{collect} with arguments.
For example, the programmer can redefine the handler to treat the
maximum nonstatic generation as a static generation over a long
period of time by calling \scheme{collect} with arguments that
prevent the maximum nonstatic generation from being collected during
that period of time.
Additional information on {\ChezScheme}'s collector can be found in the
report ``Don't stop the {BiBOP}: Flexible and efficient
@ -126,34 +119,62 @@ storage management for dynamically typed languages''~\cite{Dybvig:sm}.
%----------------------------------------------------------------------------
\entryheader
\formdef{collect}{\categoryprocedure}{(collect)}
\formdef{collect}{\categoryprocedure}{(collect \var{g})}
\formdef{collect}{\categoryprocedure}{(collect \var{g} \var{tg})}
\formdef{collect}{\categoryprocedure}{(collect \var{g} \var{tg} \var{objs})}
\formdef{collect}{\categoryprocedure}{(collect \var{cg})}
\formdef{collect}{\categoryprocedure}{(collect \var{cg} \var{max-tg})}
\formdef{collect}{\categoryprocedure}{(collect \var{cg} \var{min-tg} \var{max-tg})}
\formdef{collect}{\categoryprocedure}{(collect \var{cg} \var{min-tg} \var{max-tg} \var{objs})}
\returns a list if \var{objs} is a list, unspecified otherwise
\listlibraries
\endentryheader
\noindent
\var{g} must be a nonnegative fixnum no greater than the
maximum nonstatic generation, i.e., the
value returned by \scheme{collect-maximum-generation}.
If \var{g} is the maximum nonstatic generation,
\var{tg} must be a fixnum equal to \var{g} or the symbol
\scheme{static}.
Otherwise, \var{tg} must be a fixnum equal to or one
greater than \var{g}.
\var{objs} must be either \scheme{#f} or a list.
This procedure causes the storage manager to perform a garbage collection.
\scheme{collect} is invoked periodically via the collect-request
handler, but it may also be called explicitly to force collection at a
particular time, e.g., before timing a computation.
This procedure causes the storage manager to perform a garbage
collection.
\scheme{collect} is invoked periodically without arguments by the
default collect-request handler, but it may also be called explicitly,
e.g., from a custom collect-request handler, between phases of a
computation when collection is most likely to be successful, or
before timing a computation.
In the threaded versions of {\ChezScheme}, the thread that invokes
\scheme{collect} must be the only active thread.
The system determines which generations to collect, based on \var{g} and
\var{tg} if provided, as described in the lead-in to this section.
When called without arguments, the system determines automatically
which generations to collect and the target generation for each
collected generation as described in the lead-in to this section.
When called with arguments, the system collects all and only objects
in generations less than or equal to \var{cg} (the maximum collected
generation) into the target generation or generations determined
by \var{min-tg} (the minimum target generation) and \var{max-tg}
(the maximum target generation).
Specifically, the target generation for any object in a collected
generation \var{g} is
$\mbox{min}(\mbox{max}(\mbox{\emph{g}}+1,\mbox{\emph{min-tg}}),\mbox{\emph{max-tg}})$, where
\scheme{static} is taken to have the value one greater
than the maximum nonstatic generation.
If present, \var{cg} must be a nonnegative fixnum no greater than
the maximum nonstatic generation, i.e., the current value of the
parameter \scheme{collect-maximum-generation}.
If present, \var{max-tg} must be a nonnegative fixnum or the symbol
\scheme{static} and either equal to \var{cg} or one greater than
\var{cg}, again treating \scheme{static} as having the value one
greater than the maximum nonstatic generation.
If \var{max-tg} is not present (but \var{cg} is), it defaults to
\var{cg} if \var{cg} is equal to the maximum target generation and
to one more than \var{cg} otherwise.
If present, \var{min-tg} must be a nonnegative fixnum or the symbol
\scheme{static} and no greater than \var{max-tg}, again treating
\scheme{static} as having the value one greater than the maximum
nonstatic generation.
Unless \var{max-cg} is the same as \var{cg}, \var{min-tg} must also
be greater than \var{cg}.
If \var{min-tg} is not present (but \var{cg} is), it defaults to
the same value as \var{max-tg}.
If present, \var{objs} must be either \scheme{#f} or a list.
If \var{objs} is a list, the collection is combined with counting as
in \scheme{compute-size-increments}. Counting looks through all
generations, as when \scheme{'static} is the second argument to
@ -184,7 +205,7 @@ the collect-request handler.
Note that if the collect-request handler (see
\scheme{collect-request-handler}) does not call \scheme{collect}, then
\scheme{collect-rendezvous} does not actualy perform a garbage
\scheme{collect-rendezvous} does not actually perform a garbage
collection.

71
racket/src/ChezScheme/mats/7.ms
View File

@ -5606,6 +5606,75 @@ evaluating module init
(collect (collect-maximum-generation))
(let ([b3 (bytes-allocated)])
(and (> b2 b1) (< b3 b2))))))
(error? ; invalid generation
(collect 'static 1 'static))
(error? ; invalid generation
(collect 'static 1 'static))
(error? ; invalid generation
(parameterize ([collect-maximum-generation 4])
(collect 17 1 17)))
(error? ; invalid generation
(collect -1 1 'static))
(error? ; invalid maximum target generation
(parameterize ([collect-maximum-generation 4])
(collect 3 1 2)))
(error? ; invalid maximum target generation
(parameterize ([collect-maximum-generation 4])
(collect 3 1 'dynamic)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect 0 0 3)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect 0 'static 3)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect 0 2 1)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect 0 2 0)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect (collect-maximum-generation) 0 'static)))
(error? ; invalid minimum target generation
(parameterize ([collect-maximum-generation 4])
(collect (collect-maximum-generation) -1 'static)))
(parameterize ([collect-maximum-generation (max (collect-maximum-generation) 2)])
(with-interrupts-disabled
(collect (collect-maximum-generation))
(let ([b0-0 (bytes-allocated 0)]
[b1-0 (bytes-allocated 1)]
[bm-0 (bytes-allocated (collect-maximum-generation))])
(let* ([v (make-vector 2000)] [n (compute-size v)])
(let ([b0-1 (bytes-allocated 0)]
[b1-1 (bytes-allocated 1)]
[bm-1 (bytes-allocated (collect-maximum-generation))])
(unless (>= (- b0-1 b0-0) n) (errorf 'oops1 "b0-0 = ~s, b0-1 = ~s, b0-2 = ~s" b0-0 b0-1 b0-2))
(unless (< (- b1-1 b1-0) n) (errorf 'oops2 "b1-0 = ~s, b1-1 = ~s, b1-2 = ~s" b1-0 b1-1 b1-2))
(unless (< (- bm-1 bm-0) n) (errorf 'oops3 "bm-0 = ~s, bm-1 = ~s, bm-2 = ~s" bm-0 bm-1 bm-2))
(collect (collect-maximum-generation) 1 (collect-maximum-generation))
(let ([b0-2 (bytes-allocated 0)]
[b1-2 (bytes-allocated 1)]
[bm-2 (bytes-allocated (collect-maximum-generation))])
(unless (< (- b0-2 b0-0) n) (errorf 'oops4 "b0-0 = ~s, b0-1 = ~s, b0-2 = ~s" b0-0 b0-1 b0-2))
(unless (>= (- b1-2 b1-0) n) (errorf 'oops5 "b1-0 = ~s, b1-1 = ~s, b1-2 = ~s" b1-0 b1-1 b1-2))
(unless (< (- bm-2 bm-0) n) (errorf 'oops6 "bm-0 = ~s, bm-1 = ~s, bm-2 = ~s" bm-0 bm-1 bm-2))
(parameterize ([print-vector-length #t]) (pretty-print v))
#t))))))
(parameterize ([collect-maximum-generation 4]
[collect-generation-radix 4]
[collect-trip-bytes (expt 2 20)])
(collect (collect-maximum-generation))
(let ([b0 (maximum-memory-bytes)])
(define tail-spin
(lambda (n)
(do ([i 1 (fx+ i 1)] [next (cons 0 '()) (cdr next)])
((fx= i n))
(set-cdr! next (cons i '())))))
(tail-spin 50000000)
(let ([b1 (maximum-memory-bytes)])
(or (< (- b1 b0) (expt 2 24))
(errorf #f "b0 = ~s, b1 = ~s, b1-b0 = ~s" b0 b1 (- b1 b0))))))
)
(mat object-counts
@ -5632,7 +5701,7 @@ evaluating module init
(assert (assp record-type-descriptor? hc))
#t))
; a few idiot checks including verification of proper behavior when changing collect-maximum-generation
(parameterize ([enable-object-counts #t])
(parameterize ([enable-object-counts #t] [collect-maximum-generation (collect-maximum-generation)])
(pair?
(with-interrupts-disabled
(let ([cmg (collect-maximum-generation)])

7
racket/src/ChezScheme/mats/Mf-base
View File

@ -86,6 +86,10 @@ eval = $(defaulteval)
defaultctb = (collect-trip-bytes)
ctb = $(defaultctb)
# cn defines the value to which collect-notify is set: f for #f, t for #t
defaultcn = f
cn = $(defaultcn)
# cgr is the value to which collect-generation-radix is set.
defaultcgr = (collect-generation-radix)
cgr = $(defaultcgr)
@ -164,6 +168,7 @@ $(objdir)/%.mo : %.ms mat.so
'(heap-check-interval ${hci})'\
'(#%$$enable-check-prelex-flags #${ecpf})'\
'(compile-profile #$p)'\
'(collect-notify #${cn})'\
'(collect-trip-bytes ${ctb})'\
'(collect-generation-radix ${cgr})'\
'(collect-maximum-generation ${cmg})'\
@ -189,6 +194,7 @@ $(objdir)/%.mo : %.ms mat.so
'(heap-check-interval ${hci})'\
'(#%$$enable-check-prelex-flags #${ecpf})'\
'(compile-profile #$p)'\
'(collect-notify #${cn})'\
'(collect-trip-bytes ${ctb})'\
'(collect-generation-radix ${cgr})'\
'(collect-maximum-generation ${cmg})'\
@ -364,6 +370,7 @@ script.all$o makescript$o:
'(heap-check-interval ${hci})'\
'(#%$$enable-check-prelex-flags #${ecpf})'\
'(compile-profile #$p)'\
'(collect-notify #${cn})'\
'(collect-trip-bytes ${ctb})'\
'(collect-generation-radix ${cgr})'\
'(collect-maximum-generation ${cmg})'\

57
racket/src/ChezScheme/mats/misc.ms
View File

@ -1154,76 +1154,77 @@
)
(mat collect+compute-size-increments
(eq? (void) (collect 0 0 #f))
(eq? '() (collect 0 0 '()))
(eq? (void) (collect 0 0 0 #f))
(eq? '() (collect 0 0 0 '()))
(error? (collect 0 0 'not-a-list))
(error? (collect 0 0 0))
(error? (collect 'not-a-generation 0 '()))
(error? (collect 0 'not-a-generation '()))
(error? (collect 1 0 '()))
(error? (collect 0 0 0 'not-a-list))
(error? (collect 0 0 0 0))
(error? (collect 'not-a-generation 0 0 '()))
(error? (collect 0 'not-a-generation 0 '()))
(error? (collect 0 0 'not-a-generation '()))
(error? (collect 1 0 0 '()))
(begin
(define-record-type count-wrap (fields val))
(collect 0 0 (list (make-count-wrap 0))) ; take care of one-time initialization costs
(define wrap-size (car (collect 0 0 (list (make-count-wrap 0))))) ; includes rtd
(define just-wrap-size (cadr (collect 0 0 (list (make-count-wrap 0) (make-count-wrap 1)))))
(collect 0 0 0 (list (make-count-wrap 0))) ; take care of one-time initialization costs
(define wrap-size (car (collect 0 0 0 (list (make-count-wrap 0))))) ; includes rtd
(define just-wrap-size (cadr (collect 0 0 0 (list (make-count-wrap 0) (make-count-wrap 1)))))
(define pair-size (compute-size (cons 1 2)))
(define ephemeron-size (compute-size (ephemeron-cons 1 2)))
#t)
(equal? (list pair-size pair-size)
(collect 0 0 (list (cons 1 2) (cons 3 4))))
(collect 0 0 0 (list (cons 1 2) (cons 3 4))))
(equal? (list (* 3 pair-size) pair-size)
(let ([l (list 1 2)])
(collect 0 0 (list (cons 3 l) (cons 4 l)))))
(collect 0 0 0 (list (cons 3 l) (cons 4 l)))))
(equal? (list pair-size)
(collect 0 0 (list (weak-cons (make-bytevector 100) #f))))
(collect 0 0 0 (list (weak-cons (make-bytevector 100) #f))))
;; Ephemeron(s) found before key:
(equal? (list ephemeron-size (+ (* 2 pair-size) wrap-size))
(collect 0 0 (let* ([p (make-count-wrap (cons 0 0))]
[e (ephemeron-cons p (cons 0 0))])
(list e p))))
(collect 0 0 0 (let* ([p (make-count-wrap (cons 0 0))]
[e (ephemeron-cons p (cons 0 0))])
(list e p))))
(equal? (list ephemeron-size (+ (* 3 pair-size) wrap-size))
(let* ([v (make-count-wrap (cons 1 2))]
[e (ephemeron-cons v (cons 3 4))])
(collect 0 0 (list e (cons v #f)))))
(collect 0 0 0 (list e (cons v #f)))))
(equal? (list (* 2 (+ ephemeron-size pair-size)) (+ (* 4 pair-size) wrap-size))
(let* ([v (make-count-wrap (cons 1 2))]
[e* (list (ephemeron-cons v (cons 3 4))
(ephemeron-cons v (cons 5 6)))])
(collect 0 0 (list e* (cons v #f)))))
(collect 0 0 0 (list e* (cons v #f)))))
;; Key found before ephemeron(s):
(equal? (list (+ (* 2 pair-size) wrap-size) (+ ephemeron-size pair-size))
(let* ([v (make-count-wrap (cons 1 2))]
[e (ephemeron-cons v (cons 3 4))])
(collect 0 0 (list (cons v #f) e))))
(collect 0 0 0 (list (cons v #f) e))))
(equal? (list (* 2 pair-size) (+ (* 4 pair-size) (* 2 ephemeron-size)))
(let* ([v (cons 1 2)]
[e* (list (ephemeron-cons v (cons 3 4))
(ephemeron-cons v (cons 5 6)))])
(collect 0 0 (list (cons v #f) e*))))
(collect 0 0 0 (list (cons v #f) e*))))
;; Weakly held objects:
(equal? '(0)
(let* ([v (make-count-wrap (cons 1 2))]
[ls (weak-cons v '())])
(collect 0 0 ls)))
(collect 0 0 0 ls)))
(equal? (list wrap-size pair-size (+ just-wrap-size pair-size))
(let* ([v (make-count-wrap (cons 1 2))]
[ls (cons* (make-count-wrap 0) (cons v 1) (weak-cons v '()))])
(collect 0 0 ls)))
(collect 0 0 0 ls)))
(equal? (list 0 (+ wrap-size (* 2 pair-size)))
(let* ([v (make-count-wrap (cons 1 2))]
[ls (weak-cons v (cons (cons v 1) '()))])
(collect 0 0 ls)))
(collect 0 0 0 ls)))
(equal? #!bwp
(let* ([v (make-count-wrap (cons 1 2))]
[ls (weak-cons v '())])
(collect 0 0 ls)
(collect 0 0 0 ls)
(car ls)))
;; These calls will encounter many kinds of objects, just to make
;; sure they don't fail:
(list? (collect 0 0 (list (call/cc values))))
(list? (collect (collect-maximum-generation) (collect-maximum-generation) (list (call/cc values))))
(list? (collect 0 0 0 (list (call/cc values))))
(list? (collect (collect-maximum-generation) (collect-maximum-generation) (collect-maximum-generation) (list (call/cc values))))
(let ()
(define e (ephemeron-cons #t (gensym)))
@ -1234,7 +1235,7 @@
;; For this collection, `e` is both on the dirty list
;; and involved in measuring; make sure those roles
;; don't conflict
(collect 1 1 (list e))
(collect 1 1 1 (list e))
(equal? e (cons #!bwp #!bwp))))
(let ()
@ -1242,7 +1243,7 @@
(collect 0 1)
(let ([g (gensym)])
(set-car! e g)
(collect 1 1 (list e))
(collect 1 1 1 (list e))
(equal? e (cons g 'other))))
)

12
racket/src/ChezScheme/mats/root-experr-compile-0-f-f-f
View File

@ -7576,6 +7576,18 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat collect: "collect: invalid generation -1".
7.mo:Expected error in mat collect: "collect: invalid target generation 0 for generation 1".
7.mo:Expected error in mat collect: "collect: invalid generation static".
7.mo:Expected error in mat collect: "collect: invalid generation static".
7.mo:Expected error in mat collect: "collect: invalid generation static".
7.mo:Expected error in mat collect: "collect: invalid generation 17".
7.mo:Expected error in mat collect: "collect: invalid generation -1".
7.mo:Expected error in mat collect: "collect: invalid maximum target generation 2 for generation 3".
7.mo:Expected error in mat collect: "collect: invalid maximum target generation dynamic for generation 3".
7.mo:Expected error in mat collect: "collect: invalid maximum target generation 3 for generation 0".
7.mo:Expected error in mat collect: "collect: invalid maximum target generation 3 for generation 0".
7.mo:Expected error in mat collect: "collect: invalid minimum target generation 2 for generation 0 and maximum target generation 1".
7.mo:Expected error in mat collect: "collect: invalid minimum target generation 2 for generation 0 and maximum target generation 0".
7.mo:Expected error in mat collect: "collect: invalid minimum target generation 0 for generation 4 and maximum target generation static".
7.mo:Expected error in mat collect: "collect: invalid minimum target generation -1 for generation 4 and maximum target generation static".
7.mo:Expected error in mat sstats: "make-sstats: cpu value 0 is not a time record".
7.mo:Expected error in mat sstats: "make-sstats: real value 0 is not a time record".
7.mo:Expected error in mat sstats: "make-sstats: bytes value 0.0 is not an exact integer".

12
racket/src/ChezScheme/mats/root-experr-compile-2-f-f-f
View File

@ -7170,6 +7170,18 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat collect: "collect: invalid generation -1".
7.mo:Expected error in mat collect: "collect: invalid target generation 0 for generation 1".
7.mo:Expected error in mat collect: "collect: invalid generation static".
7.mo:Expected error in mat collect: "collect: invalid generation static".
7.mo:Expected error in mat collect: "collect: invalid generation static".
7.mo:Expected error in mat collect: "collect: invalid generation 17".
7.mo:Expected error in mat collect: "collect: invalid generation -1".
7.mo:Expected error in mat collect: "collect: invalid maximum target generation 2 for generation 3".
7.mo:Expected error in mat collect: "collect: invalid maximum target generation dynamic for generation 3".
7.mo:Expected error in mat collect: "collect: invalid maximum target generation 3 for generation 0".
7.mo:Expected error in mat collect: "collect: invalid maximum target generation 3 for generation 0".
7.mo:Expected error in mat collect: "collect: invalid minimum target generation 2 for generation 0 and maximum target generation 1".
7.mo:Expected error in mat collect: "collect: invalid minimum target generation 2 for generation 0 and maximum target generation 0".
7.mo:Expected error in mat collect: "collect: invalid minimum target generation 0 for generation 4 and maximum target generation static".
7.mo:Expected error in mat collect: "collect: invalid minimum target generation -1 for generation 4 and maximum target generation static".
7.mo:Expected error in mat sstats: "make-sstats: cpu value 0 is not a time record".
7.mo:Expected error in mat sstats: "make-sstats: real value 0 is not a time record".
7.mo:Expected error in mat sstats: "make-sstats: bytes value 0.0 is not an exact integer".

31
racket/src/ChezScheme/release_notes/release_notes.stex
View File

@ -2,7 +2,7 @@
\thisversion{Version 9.5.3}
\thatversion{Version 8.4}
\pubmonth{February}
\pubmonth{June}
\pubyear{2020}
\begin{document}
@ -112,6 +112,35 @@ unordered by default. An ordered guardian's objects are classified as
inaccessible only when they are not reachable from the represetative
of any inaccessible object in any other guardian.
\subsection{Incremental promotion of collected objects (9.5.3)}
In previous versions of {\ChezScheme}, the collector always promoted
surviving objects from every collected generation into a single
target generation.
For example, when the target generation was 3, it promoted not only
surviving objects from generation 2 to generation 3 but also surviving
objects from generations 0 and 1 directly to generation 3.
This caused some prematurely promoted objects to be subjected to
collection less frequently than their ages justified, potentially
resulting in substantial inappropriate storage retention.
This is particularly problematic when side effects result in pointers
from the inappropriately retained objects to younger objects, as
can happen with nonfunctional queues and lazy streams.
Unless directed to do otherwise, the collector now promotes objects
up only one generation at a time.
That is, generation 0 objects that survive collection are promoted
to generation 1, generation 1 objects are promoted to generation
2, and so on.
(Objects that survive a maximum nonstatic collection are promoted
back into the maximum nonstatic collection.)
Most applications should exhibit lower peak memory usage and possibly
lower run times with this change.
Applications that are adversely affected, if any, might benefit
from a custom collect-request handler or custom values for the
collection parameters that affect the behavior of the default
handler.
\subsection{Unicode Basic Multilingual Plane console I/O in Windows (9.5.3)}
Console I/O now supports characters from the Unicode Basic

69
racket/src/ChezScheme/s/7.ss
View File

@ -795,23 +795,23 @@
(define gc-count 0)
(define start-bytes 0)
(define docollect
(let ([do-gc (foreign-procedure "(cs)do_gc" (int int ptr) ptr)])
(let ([do-gc (foreign-procedure "(cs)do_gc" (int int int ptr) ptr)])
(lambda (p)
(with-tc-mutex
(unless (= $active-threads 1)
($oops 'collect "cannot collect when multiple threads are active"))
(let-values ([(trip g gtarget count-roots) (p gc-trip)])
(let-values ([(trip g gmintarget gmaxtarget count-roots) (p gc-trip)])
(set! gc-trip trip)
(let ([cpu (current-time 'time-thread)] [real (current-time 'time-monotonic)])
(set! gc-bytes (+ gc-bytes (bytes-allocated)))
(when (collect-notify)
(fprintf (console-output-port)
"~%[collecting generation ~s into generation ~s..."
g gtarget)
g gmaxtarget)
(flush-output-port (console-output-port)))
(when (eqv? g (collect-maximum-generation))
($clear-source-lines-cache))
(let ([gc-result (do-gc g gtarget count-roots)])
(let ([gc-result (do-gc g gmintarget gmaxtarget count-roots)])
($close-resurrected-files)
(when-feature pthreads
($close-resurrected-mutexes&conditions))
@ -854,14 +854,15 @@
(docollect
(lambda (gct)
(let ([gct (+ gct 1)])
(let loop ([g (collect-maximum-generation)])
(if (= (modulo gct (expt (collect-generation-radix) g)) 0)
(if (fx= g (collect-maximum-generation))
(values 0 g g #f)
(values gct g (fx+ g 1) #f))
(loop (fx- g 1)))))))))
(let ([cmg (collect-maximum-generation)])
(let loop ([g cmg])
(if (= (modulo gct (expt (collect-generation-radix) g)) 0)
(if (fx= g cmg)
(values 0 g (fxmin g 1) g #f)
(values gct g 1 (fx+ g 1) #f))
(loop (fx- g 1))))))))))
(define collect2
(lambda (g gtarget count-roots)
(lambda (g gmintarget gmaxtarget count-roots)
(docollect
(lambda (gct)
(values
@ -875,24 +876,44 @@
(+ gct (modulo (- n gct) n))))
(let ([next (trip g)] [limit (trip (fx+ g 1))])
(if (< next limit) next (- limit 1)))))
g gtarget count-roots)))))
g gmintarget gmaxtarget count-roots)))))
(case-lambda
[() (collect0)]
[(g)
(unless (and (fixnum? g) (fx<= 0 g (collect-maximum-generation)))
($oops who "invalid generation ~s" g))
(collect2 g (if (fx= g (collect-maximum-generation)) g (fx+ g 1)) #f)]
[(g gtarget) (collect g gtarget #f)]
[(g gtarget count-roots)
(unless (and (fixnum? g) (fx<= 0 g (collect-maximum-generation)))
($oops who "invalid generation ~s" g))
(unless (if (fx= g (collect-maximum-generation))
(or (eqv? gtarget g) (eq? gtarget 'static))
(or (eqv? gtarget g) (eqv? gtarget (fx+ g 1))))
($oops who "invalid target generation ~s for generation ~s" gtarget g))
(let ([cmg (collect-maximum-generation)])
(unless (and (fixnum? g) (fx<= 0 g cmg))
($oops who "invalid generation ~s" g))
(let ([gtarget (if (fx= g cmg) g (fx+ g 1))])
(collect2 g gtarget gtarget #f)))]
[(g gtarget)
(let ([cmg (collect-maximum-generation)])
(unless (and (fixnum? g) (fx<= 0 g cmg))
($oops who "invalid generation ~s" g))
(unless (if (fx= g cmg)
(or (eqv? gtarget g) (eq? gtarget 'static))
(or (eqv? gtarget g) (eqv? gtarget (fx+ g 1))))
($oops who "invalid target generation ~s for generation ~s" gtarget g)))
(let ([gtarget (if (eq? gtarget 'static) (constant static-generation) gtarget)])
(collect2 g gtarget gtarget #f))]
[(g gmintarget gmaxtarget) (collect g gmintarget gmaxtarget #f)]
[(g gmintarget gmaxtarget count-roots)
(let ([cmg (collect-maximum-generation)])
(unless (and (fixnum? g) (fx<= 0 g cmg))
($oops who "invalid generation ~s" g))
(unless (if (fx= g cmg)
(or (eqv? gmaxtarget g) (eq? gmaxtarget 'static))
(or (eqv? gmaxtarget g) (eqv? gmaxtarget (fx+ g 1))))
($oops who "invalid maximum target generation ~s for generation ~s" gmaxtarget g))
(unless (or (eqv? gmintarget gmaxtarget)
(and (fixnum? gmintarget)
(fx<= 1 gmintarget (if (fixnum? gmaxtarget) gmaxtarget cmg))))
($oops who "invalid minimum target generation ~s for generation ~s and maximum target generation ~s" gmintarget g gmaxtarget)))
(unless (or (not count-roots) (list? count-roots))
($oops who "invalid counting-roots list ~s" count-roots))
(collect2 g (if (eq? gtarget 'static) (constant static-generation) gtarget) count-roots)])))
(collect2 g
(if (eq? gmintarget 'static) (constant static-generation) gmintarget)
(if (eq? gmaxtarget 'static) (constant static-generation) gmaxtarget)
count-roots)])))
(set! collect-rendezvous
(let ([fire-collector (foreign-procedure "(cs)fire_collector" () void)])

230
racket/src/ChezScheme/s/mkgc.ss
View File

@ -78,10 +78,12 @@
;; inferred for `space-data`
;; * counting-root : check a counting root before pushing to sweep stack
;; - (trace <field>) : relocate for sweep, copy for copy, recur otherwise
;; - (trace-early <field>) : relocate for sweep, copy, and mark; recur otherwise
;; - (trace-now <field>) : direct recur
;; - (trace-early-rtd <field>) : for record types, avoids recur on #!base-rtd
;; - (trace-pure <field>) : like `trace`, but no need for generation tracking
;; - (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-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
;; - (copy-bytes <field> <count>) : copy an array of bytes
;; - (copy-flonum <field>) : copy flonum and forward
@ -206,7 +208,7 @@
(copy-clos-code code)
(copy-stack-length continuation-stack-length continuation-stack-clength)
(copy continuation-stack-clength)
(trace-nonself continuation-winders)
(trace-pure-nonself continuation-winders)
(trace-nonself continuation-attachments)
(cond
[(== (continuation-stack-length _) scaled-shot-1-shot-flag)]
@ -220,7 +222,7 @@
(continuation-stack-clength _))))]
[else])
(count countof-stack (continuation-stack-length _) 1 [sweep measure])
(trace continuation-link)
(trace-pure continuation-link)
(trace-return continuation-return-address (continuation-return-address _))
(case-mode
[copy (copy continuation-stack)]
@ -258,10 +260,15 @@
[else
(mark counting-root)
(count countof-closure)]))
(when (or-not-as-dirty
(& (code-type code) (<< code-flag-mutable-closure code-flags-offset)))
(copy-clos-code code)
(trace-ptrs closure-data len))
(cond
[(and-purity-sensitive-mode
(& (code-type code) (<< code-flag-mutable-closure code-flags-offset)))
(copy-clos-code code)
(trace-ptrs closure-data len)]
[(and-not-as-dirty 1)
(copy-clos-code code)
(trace-pure-ptrs closure-data len)]
[else])
(pad (when (== (& len 1) 0)
(set! (closure-data _copy_ len) (FIX 0))))
(count countof-closure)])]
@ -458,8 +465,8 @@
(vspace vspace_impure) ; would be better if we had pure, but these are rare
(size size-ratnum)
(copy-type ratnum-type)
(trace-immutable-now ratnum-numerator)
(trace-immutable-now ratnum-denominator)
(trace-now ratnum-numerator)
(trace-now ratnum-denominator)
(mark)
(vfasl-pad-word)
(count countof-ratnum)]
@ -469,8 +476,8 @@
(vspace vspace_impure) ; same rationale as ratnum
(size size-exactnum)
(copy-type exactnum-type)
(trace-immutable-now exactnum-real)
(trace-immutable-now exactnum-imag)
(trace-now exactnum-real)
(trace-now exactnum-imag)
(mark)
(vfasl-pad-word)
(count countof-exactnum)]
@ -519,11 +526,11 @@
(copy-type code-type)
(copy code-length)
(copy code-reloc)
(trace-nonself code-name)
(trace-nonself code-arity-mask)
(trace-pure-nonself code-name)
(trace-pure-nonself code-arity-mask)
(copy code-closure-length)
(trace-nonself code-info)
(trace-nonself code-pinfo*)
(trace-pure-nonself code-info)
(trace-pure-nonself code-pinfo*)
(trace-code len))
(count countof-code)]
@ -575,6 +582,12 @@
[else
(trace field)]))
(define-trace-macro (trace-pure-nonself field)
(case-mode
[self-test]
[else
(trace-pure field)]))
(define-trace-macro (trace-nonself/vfasl-as-nil field)
(case-mode
[vfasl-copy
@ -611,7 +624,7 @@
(set! (FWDMARKER cdr_p) forward_marker)
(set! (FWDADDRESS cdr_p) new_cdr_p)
(case-flag maybe-backreferences?
[on (ADD_BACKREFERENCE_FROM new_cdr_p new_p)]
[on (ADD_BACKREFERENCE_FROM new_cdr_p new_p _tg_)]
[off])
(count count-pair size-pair 2)]
[else
@ -646,10 +659,6 @@
(constant byte-alignment))
(constant bytes-per-segment))))
(define-trace-macro (trace-immutable-now ref)
(when (and-not-as-dirty 1)
(trace-now ref)))
(define-trace-macro (trace-code-early code)
(unless-code-relocated
(case-mode
@ -692,9 +701,8 @@
[(copy measure)
(trace ref)]
[sweep
(define val : ptr (ref _))
(trace (just val))
(set! (ref _) val)]
(trace ref) ; can't trace `val` directly, because we need an impure relocate
(define val : ptr (ref _))]
[vfasl-copy
(set! (ref _copy_) vfasl-val)]
[else]))
@ -705,7 +713,9 @@
(define code : ptr (cond
[(Sprocedurep val) (CLOSCODE val)]
[else (SYMCODE _)]))
(trace (just code))
(case-flag as-dirty?
[on (trace (just code))]
[off (trace-pure (just code))])
(INITSYMCODE _ code)]
[measure]
[vfasl-copy
@ -772,7 +782,7 @@
(case-mode
[(sweep self-test)
;; Bignum pointer mask may need forwarding
(trace (record-type-pm rtd))
(trace-pure (record-type-pm rtd))
(set! num (record-type-pm rtd))]
[else])])
(let* ([index : iptr (- (BIGLEN num) 1)]
@ -854,8 +864,8 @@
;; For max_copied_generation, the list will get copied again in `rtds_with_counts` fixup;
;; meanwhile, allocating in `space_impure` would copy and sweep old list entries causing
;; otherwise inaccessible rtds to be retained
(S_cons_in (cond [(<= grtd max_copied_generation) space_new] [else space_impure])
(cond [(<= grtd max_copied_generation) 0] [else grtd])
(S_cons_in (cond [(<= grtd MAX_CG) space_new] [else space_impure])
(cond [(<= grtd MAX_CG) 0] [else grtd])
c_rtd
(array-ref S_G.rtds_with_counts grtd)))
(set! (array-ref (array-ref S_G.countof grtd) countof_pair) += 1))]
@ -913,10 +923,10 @@
(measure_add_stack_size (tc-scheme-stack tc) (tc-scheme-stack-size tc))]
[else])
(set! (tc-stack-cache tc) Snil)
(trace (tc-cchain tc))
(trace (tc-stack-link tc))
(trace (tc-winders tc))
(trace (tc-attachments tc))
(trace-pure (tc-cchain tc))
(trace-pure (tc-stack-link tc))
(trace-pure (tc-winders tc))
(trace-pure (tc-attachments tc))
(case-mode
[sweep
(set! (tc-cached-frame tc) Sfalse)]
@ -933,26 +943,26 @@
(set! (tc-X tc) 0)
(set! (tc-Y tc) 0)]
[else])
(trace (tc-threadno tc))
(trace (tc-current-input tc))
(trace (tc-current-output tc))
(trace (tc-current-error tc))
(trace (tc-sfd tc))
(trace (tc-current-mso tc))
(trace (tc-target-machine tc))
(trace (tc-fxlength-bv tc))
(trace (tc-fxfirst-bit-set-bv tc))
(trace (tc-null-immutable-vector tc))
(trace (tc-null-immutable-fxvector tc))
(trace (tc-null-immutable-bytevector tc))
(trace (tc-null-immutable-string tc))
(trace (tc-compile-profile tc))
(trace (tc-subset-mode tc))
(trace (tc-default-record-equal-procedure tc))
(trace (tc-default-record-hash-procedure tc))
(trace (tc-compress-format tc))
(trace (tc-compress-level tc))
(trace (tc-parameters tc))
(trace-pure (tc-threadno tc))
(trace-pure (tc-current-input tc))
(trace-pure (tc-current-output tc))
(trace-pure (tc-current-error tc))
(trace-pure (tc-sfd tc))
(trace-pure (tc-current-mso tc))
(trace-pure (tc-target-machine tc))
(trace-pure (tc-fxlength-bv tc))
(trace-pure (tc-fxfirst-bit-set-bv tc))
(trace-pure (tc-null-immutable-vector tc))
(trace-pure (tc-null-immutable-fxvector tc))
(trace-pure (tc-null-immutable-bytevector tc))
(trace-pure (tc-null-immutable-string tc))
(trace-pure (tc-compile-profile tc))
(trace-pure (tc-subset-mode tc))
(trace-pure (tc-default-record-equal-procedure tc))
(trace-pure (tc-default-record-hash-procedure tc))
(trace-pure (tc-compress-format tc))
(trace-pure (tc-compress-level tc))
(trace-pure (tc-parameters tc))
(case-mode
[(sweep)
(set! (tc-DSTBV tc) Sfalse)
@ -961,7 +971,7 @@
(let* ([i : INT 0])
(while
:? (< i virtual_register_count)
(trace (tc-virtual-registers tc i))
(trace-pure (tc-virtual-registers tc i))
(set! i += 1))))]))
(define-trace-macro (trace-stack base-expr fp-expr ret-expr)
@ -986,10 +996,10 @@
:? (!= mask 0)
(set! pp += 1)
(when (& mask #x0001)
(trace (* pp)))
(trace-pure (* pp)))
(set! mask >>= 1)))]
[else
(trace (* (ENTRYNONCOMPACTLIVEMASKADDR oldret)))
(trace-pure (* (ENTRYNONCOMPACTLIVEMASKADDR oldret)))
(let* ([num : ptr (ENTRYLIVEMASK oldret)]
[index : iptr (BIGLEN num)])
@ -1002,7 +1012,7 @@
:? (> bits 0)
(set! bits -= 1)
(set! pp += 1)
(when (& mask 1) (trace (* pp)))
(when (& mask 1) (trace-pure (* pp)))
(set! mask >>= 1)))))])))))
(define-trace-macro (trace-return copy-field field)
@ -1023,7 +1033,7 @@
(relocate_code c_p x_si)
(set! field (cast ptr (+ (cast uptr c_p) co))))]
[else
(trace (just c_p))]))
(trace-pure (just c_p))]))
(define-trace-macro (trace-code len)
(case-mode
@ -1072,7 +1082,7 @@
[vfasl-sweep
(set! obj (vfasl_encode_relocation vfi obj))]
[else
(trace (just obj))])
(trace-pure (just obj))])
(case-mode
[sweep
(S_set_code_obj "gc" (RELOC_TYPE entry) _ a obj item_off)]
@ -1083,7 +1093,7 @@
(case-mode
[sweep
(cond
[(&& (== target_generation static_generation)
[(&& (== from_g static_generation)
(&& (! S_G.retain_static_relocation)
(== 0 (& (code-type _) (<< code_flag_template code_flags_offset)))))
(set! (code-reloc _) (cast ptr 0))]
@ -1098,7 +1108,7 @@
(mark_typemod_data_object t n t_si)]
[else
(let* ([oldt : ptr t])
(find_room space_data target_generation typemod n t)
(find_room space_data from_g typemod n t)
(memcpy_aligned (TO_VOIDP t) (TO_VOIDP oldt) n))])))
(set! (reloc-table-code t) _)
(set! (code-reloc _) t)])
@ -1142,6 +1152,11 @@
[vfasl-copy 1]
[else e]))
(define-trace-macro (and-purity-sensitive-mode e)
(case-mode
[sweep e]
[else 0]))
(define-trace-macro (when-vfasl e)
(case-mode
[(vfasl-copy vfasl-sweep) e]
@ -1320,13 +1335,13 @@
(code
(format "static ~a ~a(~aptr p~a)"
(case (lookup 'mode config)
[(copy vfasl-copy) "ptr"]
[(copy mark) "IGEN"]
[(vfasl-copy) "ptr"]
[(size vfasl-sweep) "uptr"]
[(self-test) "IBOOL"]
[(sweep) (if (lookup 'as-dirty? config #f)
"IGEN"
"void")]
[(mark) "void"]
[else "void"])
name
(case (lookup 'mode config)
@ -1339,11 +1354,15 @@
"vfasl_info *vfi, "]
[else ""])
(case (lookup 'mode config)
[(copy mark vfasl-copy) ", seginfo *si"]
[(copy) ", seginfo *si, ptr *dest"]
[(mark vfasl-copy) ", seginfo *si"]
[(sweep)
(if (lookup 'as-dirty? config #f)
", IGEN tg, IGEN youngest"
"")]
(cond
[(lookup 'as-dirty? config #f) ", IGEN youngest"]
[(and (lookup 'from-g-only-counting? config #f)
(not (lookup 'counts? config #f)))
", IGEN UNUSED(from_g)"]
[else ", IGEN from_g"])]
[else ""]))
(let ([body
(lambda ()
@ -1376,20 +1395,22 @@
"check_triggers(si);"
(code-block
"ptr new_p;"
"IGEN tg = target_generation;"
"IGEN tg = TARGET_GENERATION(si);"
(body)
"FWDMARKER(p) = forward_marker;"
"FWDADDRESS(p) = new_p;"
(and (lookup 'maybe-backreferences? config #f)
"ADD_BACKREFERENCE(p)")
"return new_p;"))]
"ADD_BACKREFERENCE(p, tg);")
"*dest = new_p;"
"return tg;"))]
[(mark)
(code-block
"change = 1;"
"check_triggers(si);"
(ensure-segment-mark-mask "si" "" '())
(body)
"ADD_BACKREFERENCE(p)")]
"ADD_BACKREFERENCE(p, si->generation);"
"return si->generation;")]
[(sweep)
(code-block
(and (lookup 'maybe-backreferences? config #f)
@ -1522,10 +1543,14 @@
[else #f])
(statements (cdr l) (cons `(copy-extra-rtd ,field) config)))]
[`(trace ,field)
(code (trace-statement field config #f)
(code (trace-statement field config #f 'impure)
(statements (cdr l) config))]
[`(trace-pure ,field)
(code (and (not (lookup 'as-dirty? config #f))
(trace-statement field config #f 'pure))
(statements (cdr l) config))]
[`(trace-early ,field)
(code (trace-statement field config #t)
(code (trace-statement field config #t 'pure)
(statements (cdr l) (if (symbol? field)
(cons `(copy-extra ,field) config)
config)))]
@ -1535,15 +1560,16 @@
[(copy)
(code-block
(format "ptr tmp_p = ~a;" (field-expression field config "p" #f))
(relocate-statement "tmp_p" config)
(relocate-statement 'pure "tmp_p" config)
(format "~a = tmp_p;" (field-expression field config "new_p" #f)))]
[(self-test) #f]
[(measure vfasl-copy vfasl-sweep)
(statements (list `(trace ,field)) config)]
[(mark)
(relocate-statement (field-expression field config "p" #t) config)]
(relocate-statement 'pure (field-expression field config "p" #t) config)]
[else
(trace-statement field config #f)])
(and (not (lookup 'as-dirty? config #f))
(trace-statement field config #f 'pure))])
(statements (cdr l) config))]
[`(copy ,field)
(code (copy-statement field config)
@ -1599,6 +1625,14 @@
[else
(statements (cons `(copy ,field) (cdr l)) config)])]
[`(trace-ptrs ,offset ,len)
(statements (cons `(trace-ptrs ,offset ,len impure)
(cdr l))
config)]
[`(trace-pure-ptrs ,offset ,len)
(statements (cons `(trace-ptrs ,offset ,len pure)
(cdr l))
config)]
[`(trace-ptrs ,offset ,len ,purity)
(case (lookup 'mode config)
[(copy vfasl-copy)
(statements (cons `(copy-bytes ,offset (* ptr_bytes ,len))
@ -1609,8 +1643,9 @@
(loop-over-pointers
(field-expression offset config "p" #t)
len
(trace-statement `(array-ref p_p idx) config #f)
config))]
(trace-statement `(array-ref p_p idx) config #f purity)
config)
(statements (cdr l) config))]
[(self-test)
(code
(loop-over-pointers (field-expression offset config "p" #t)
@ -1743,7 +1778,8 @@
[(copy)
(unless (null? (cdr l))
(error 'skip-forwarding "not at end"))
(code "return new_p;")]
(code "*dest = new_p;"
"return tg;")]
[else
(statements (cdr l) config)])]
[`(mark . ,flags)
@ -1813,7 +1849,7 @@
(cond
[(equal? tst "1")
(if else?
(code-block "else" rhs)
(code "else" (code-block rhs))
rhs)]
[else
(code (format "~aif (~a)" (if else? "else " "") tst)
@ -1902,6 +1938,7 @@
[`_tg_
(case (lookup 'mode config)
[(copy) "tg"]
[(mark) "TARGET_GENERATION(si)"]
[else "target_generation"])]
[`_backreferences?_
(if (lookup 'maybe-backreferences? config #f)
@ -2016,14 +2053,14 @@
"for (idx = 0; idx < p_len; idx++)"
(code-block body)))
(define (trace-statement field config early?)
(define (trace-statement field config early? purity)
(define mode (lookup 'mode config))
(cond
[(or (eq? mode 'sweep)
(eq? mode 'vfasl-sweep)
(and early? (or (eq? mode 'copy)
(eq? mode 'mark))))
(relocate-statement (field-expression field config "p" #t) config)]
(relocate-statement purity (field-expression field config "p" #t) config)]
[(or (eq? mode 'copy)
(eq? mode 'vfasl-copy))
(copy-statement field config)]
@ -2033,15 +2070,17 @@
(format "if (p == ~a) return 1;" (field-expression field config "p" #f))]
[else #f]))
(define (relocate-statement e config)
(define (relocate-statement purity e config)
(define mode (lookup 'mode config))
(case mode
[(vfasl-sweep)
(format "vfasl_relocate(vfi, &~a);" e)]
[else
(if (lookup 'as-dirty? config #f)
(format "relocate_dirty(&~a, tg, youngest);" e)
(format "relocate(&~a);" e))]))
(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" "")))]))
(define (measure-statement e)
(code
@ -2075,9 +2114,11 @@
[(or (eq? mode modes) (and (pair? modes) (memq mode modes)))
(cond
[(lookup 'counts? config #f)
(let ([tg (if (eq? real-mode 'copy)
"tg"
"target_generation")])
(let ([tg (case real-mode
[(copy) "tg"]
[(sweep) "from_g"]
[(mark) "TARGET_GENERATION(si)"]
[else "target_generation"])])
(code
(format "S_G.countof[~a][~a] += ~a;" tg (as-c counter) scale)
(if (lookup 'constant-size? config #f)
@ -2144,13 +2185,14 @@
"if (seg == end_seg) {"
" si->marked_count += p_sz;"
"} else {"
" seginfo *mark_si;"
" seginfo *mark_si; IGEN g;"
" si->marked_count += ((uptr)build_ptr(seg+1,0)) - addr;"
" seg++;"
" while (seg < end_seg) {"
" mark_si = SegInfo(seg);"
" if (!fully_marked_mask) init_fully_marked_mask();"
" mark_si->marked_mask = fully_marked_mask;"
" g = mark_si->generation;"
" if (!fully_marked_mask[g]) init_fully_marked_mask(g);"
" mark_si->marked_mask = fully_marked_mask[g];"
" mark_si->marked_count = segment_bitmap_bytes;"
" seg++;"
" }"
@ -2239,8 +2281,8 @@
(define (ensure-segment-mark-mask si inset flags)
(code
(format "~aif (!~a->marked_mask) {" inset si)
(format "~a find_room_voidp(space_data, target_generation, ptr_align(segment_bitmap_bytes), ~a->marked_mask);"
inset si)
(format "~a find_room_voidp(space_data, ~a->generation, ptr_align(segment_bitmap_bytes), ~a->marked_mask);"
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))
@ -2444,7 +2486,7 @@
(as-dirty? #t)))
(sweep1 'symbol)
(sweep1 'symbol "sweep_dirty_symbol" '((as-dirty? #t)))
(sweep1 'thread)
(sweep1 'thread "sweep_thread" '((from-g-only-counting? #t)))
(sweep1 'port)
(sweep1 'port "sweep_dirty_port" '((as-dirty? #t)))
(sweep1 'closure "sweep_continuation" '((code-relocated? #t)

2
racket/src/ChezScheme/s/primdata.ss
View File

@ -1224,7 +1224,7 @@
(chmod [sig [(pathname sub-ufixnum) -> (void)]] [flags])
(clear-input-port [sig [() (input-port) -> (void)]] [flags true])
(clear-output-port [sig [() (output-port) -> (void)]] [flags true])
(collect [sig [() (sub-ufixnum) (sub-ufixnum ptr) (sub-ufixnum ptr ptr) -> (void/list)]] [flags true])
(collect [sig [() (sub-ufixnum) (sub-ufixnum ptr) (sub-ufixnum ptr ptr) (sub-ufixnum ptr ptr ptr) -> (void)]] [flags true])
(collect-rendezvous [sig [() -> (void)]] [flags])
(collections [sig [() -> (uint)]] [flags unrestricted alloc])
(compile [sig [(sub-ptr) (sub-ptr environment) -> (ptr ...)]] [flags])