1955 lines
68 KiB
C
1955 lines
68 KiB
C
/* gc.c
|
|
* Copyright 1984-2016 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.
|
|
*/
|
|
|
|
#include "system.h"
|
|
#include "sort.h"
|
|
#ifndef WIN32
|
|
#include <sys/wait.h>
|
|
#endif /* WIN32 */
|
|
|
|
#define enable_object_counts do_not_use_enable_object_counts_in_this_file_use_ifdef_ENABLE_OBJECT_COUNTS_instead
|
|
|
|
/* locally defined functions */
|
|
static ptr append_bang PROTO((ptr ls1, ptr ls2));
|
|
static uptr count_unique PROTO((ptr ls));
|
|
static uptr list_length PROTO((ptr ls));
|
|
static ptr dosort PROTO((ptr ls, uptr n));
|
|
static ptr domerge PROTO((ptr l1, ptr l2));
|
|
static IBOOL search_locked PROTO((ptr p));
|
|
static ptr copy PROTO((ptr pp, ISPC pps));
|
|
static void sweep_ptrs PROTO((ptr *p, iptr n));
|
|
static void sweep PROTO((ptr tc, ptr p, IBOOL sweep_pure));
|
|
static ptr copy_stack PROTO((ptr old, iptr *length, iptr clength));
|
|
static void resweep_weak_pairs PROTO((IGEN g));
|
|
static void forward_or_bwp PROTO((ptr *pp, ptr p));
|
|
static void sweep_generation PROTO((ptr tc, IGEN g));
|
|
static iptr size_object PROTO((ptr p));
|
|
static iptr sweep_typed_object PROTO((ptr p));
|
|
static void sweep_symbol PROTO((ptr p));
|
|
static void sweep_port PROTO((ptr p));
|
|
static void sweep_thread PROTO((ptr p));
|
|
static void sweep_continuation PROTO((ptr p));
|
|
static void sweep_stack PROTO((uptr base, uptr size, uptr ret));
|
|
static void sweep_record PROTO((ptr x));
|
|
static IGEN sweep_dirty_record PROTO((ptr x));
|
|
static void sweep_code_object PROTO((ptr tc, ptr co));
|
|
static void record_dirty_segment PROTO((IGEN from_g, IGEN to_g, seginfo *si));
|
|
static void sweep_dirty PROTO((void));
|
|
static void resweep_dirty_weak_pairs PROTO((void));
|
|
|
|
/* MAXPTR is used to pad the sorted_locked_object vector. The pad value must be greater than any heap address */
|
|
#define MAXPTR ((ptr)-1)
|
|
|
|
#define OLDSPACE(x) (SPACE(x) & space_old)
|
|
|
|
/* #define DEBUG */
|
|
|
|
/* initialized and used each gc cycle. any others should be defined in globals.h */
|
|
static IBOOL change;
|
|
static IGEN target_generation;
|
|
static IGEN max_copied_generation;
|
|
static ptr sweep_loc[max_real_space+1];
|
|
static ptr orig_next_loc[max_real_space+1];
|
|
static ptr sorted_locked_objects;
|
|
static ptr tlcs_to_rehash;
|
|
|
|
static ptr append_bang(ptr ls1, ptr ls2) { /* assumes ls2 pairs are older than ls1 pairs, or that we don't car */
|
|
if (ls2 == Snil) {
|
|
return ls1;
|
|
} else if (ls1 == Snil) {
|
|
return ls2;
|
|
} else {
|
|
ptr this = ls1, next;
|
|
while ((next = Scdr(this)) != Snil) this = next;
|
|
INITCDR(this) = ls2;
|
|
return ls1;
|
|
}
|
|
}
|
|
|
|
static uptr count_unique(ls) ptr ls; { /* assumes ls is sorted and nonempty */
|
|
uptr i = 1; ptr x = Scar(ls), y;
|
|
while ((ls = Scdr(ls)) != Snil) {
|
|
if ((y = Scar(ls)) != x) {
|
|
i += 1;
|
|
x = y;
|
|
}
|
|
}
|
|
return i;
|
|
}
|
|
|
|
#define CARLT(x, y) (Scar(x) < Scar(y))
|
|
mkmergesort(dosort, domerge, ptr, Snil, CARLT, INITCDR)
|
|
|
|
uptr list_length(ptr ls) {
|
|
uptr i = 0;
|
|
while (ls != Snil) { ls = Scdr(ls); i += 1; }
|
|
return i;
|
|
}
|
|
|
|
#define relocate(ppp) {\
|
|
ptr PP;\
|
|
PP = *ppp;\
|
|
relocate_help(ppp, PP)\
|
|
}
|
|
|
|
/* optimization of:
|
|
* relocate(ppp)
|
|
* if (GENERATION(*ppp) < youngest)
|
|
* youngest = GENERATION(*ppp);
|
|
*/
|
|
#define relocate_dirty(ppp,tg,youngest) {\
|
|
ptr PP = *ppp; seginfo *SI; ISPC S;\
|
|
if (!IMMEDIATE(PP) && (SI = MaybeSegInfo(ptr_get_segment(PP))) != NULL) {\
|
|
if ((S = SI->space) & space_old) {\
|
|
relocate_help_help(ppp, PP, S)\
|
|
youngest = tg;\
|
|
} else {\
|
|
IGEN pg;\
|
|
if (youngest != tg && (pg = SI->generation) < youngest) {\
|
|
youngest = pg;\
|
|
}\
|
|
}\
|
|
}\
|
|
}
|
|
|
|
#define relocate_help(ppp, pp) {\
|
|
seginfo *SI; ISPC S;\
|
|
if (!IMMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL && (S = SI->space) & space_old)\
|
|
relocate_help_help(ppp, pp, S)\
|
|
}
|
|
|
|
#define relocate_help_help(ppp, pp, s) {\
|
|
if (FWDMARKER(pp) == forward_marker && TYPEBITS(pp) != type_flonum)\
|
|
*ppp = FWDADDRESS(pp);\
|
|
else\
|
|
*ppp = copy(pp, s);\
|
|
}
|
|
|
|
#define relocate_return_addr(pcp) {\
|
|
ISPC S;\
|
|
ptr XCP;\
|
|
XCP = *(pcp);\
|
|
if ((S = SPACE(XCP)) & space_old) {\
|
|
iptr CO;\
|
|
CO = ENTRYOFFSET(XCP) + ((uptr)XCP - (uptr)&ENTRYOFFSET(XCP));\
|
|
relocate_code(pcp,XCP,CO,S)\
|
|
}\
|
|
}
|
|
|
|
/* in the call to copy below, assuming SPACE(PP) == SPACE(XCP) since
|
|
PP and XCP point to/into the same object */
|
|
#define relocate_code(pcp,XCP,CO,S) {\
|
|
ptr PP;\
|
|
PP = (ptr)((uptr)XCP - CO);\
|
|
if (FWDMARKER(PP) == forward_marker)\
|
|
PP = FWDADDRESS(PP);\
|
|
else\
|
|
PP = copy(PP, S);\
|
|
*pcp = (ptr)((uptr)PP + CO);\
|
|
}
|
|
|
|
/* rkd 2015/06/05: tried to use sse instructions. abandoned the code
|
|
because the collector ran slower */
|
|
#define copy_ptrs(ty, p1, p2, n) {\
|
|
ptr *Q1, *Q2, *Q1END;\
|
|
Q1 = (ptr *)UNTYPE((p1),ty);\
|
|
Q2 = (ptr *)UNTYPE((p2),ty);\
|
|
Q1END = (ptr *)((uptr)Q1 + n);\
|
|
while (Q1 != Q1END) *Q1++ = *Q2++;}
|
|
|
|
static IBOOL search_locked(ptr p) {
|
|
uptr k; ptr v, *vp, x;
|
|
v = sorted_locked_objects;
|
|
k = Svector_length(v);
|
|
vp = &INITVECTIT(v, 0);
|
|
for (;;) {
|
|
k >>= 1;
|
|
if ((x = vp[k]) == p) return 1;
|
|
if (k == 0) return 0;
|
|
if (x < p) vp += k + 1;
|
|
}
|
|
}
|
|
|
|
#define locked(p) (sorted_locked_objects != FIX(0) && search_locked(p))
|
|
|
|
static ptr copy(pp, pps) ptr pp; ISPC pps; {
|
|
ptr p, tf; ITYPE t; IGEN tg;
|
|
|
|
if (locked(pp)) return pp;
|
|
|
|
tg = target_generation;
|
|
|
|
change = 1;
|
|
|
|
if ((t = TYPEBITS(pp)) == type_typed_object) {
|
|
tf = TYPEFIELD(pp);
|
|
if (TYPEP(tf, mask_record, type_record)) {
|
|
ptr rtd; iptr n; ISPC s;
|
|
|
|
/* relocate to make sure we aren't using an oldspace descriptor
|
|
that has been overwritten by a forwarding marker, but don't loop
|
|
on tag-reflexive base descriptor */
|
|
if ((rtd = tf) != pp) relocate(&rtd)
|
|
|
|
n = size_record_inst(UNFIX(RECORDDESCSIZE(rtd)));
|
|
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
{ ptr counts; IGEN g;
|
|
counts = RECORDDESCCOUNTS(rtd);
|
|
if (counts == Sfalse) {
|
|
IGEN grtd = rtd == pp ? tg : GENERATION(rtd);
|
|
S_G.countof[grtd][countof_rtd_counts] += 1;
|
|
/* allocate counts struct in same generation as rtd. initialize timestamp & counts */
|
|
find_room(space_data, grtd, type_typed_object, size_rtd_counts, counts);
|
|
RTDCOUNTSTYPE(counts) = type_rtd_counts;
|
|
RTDCOUNTSTIMESTAMP(counts) = S_G.gctimestamp[0];
|
|
for (g = 0; g <= static_generation; g += 1) RTDCOUNTSIT(counts, g) = 0;
|
|
RECORDDESCCOUNTS(rtd) = counts;
|
|
S_G.rtds_with_counts[grtd] = S_cons_in((grtd == 0 ? space_new : space_impure), grtd, rtd, S_G.rtds_with_counts[grtd]);
|
|
S_G.countof[grtd][countof_pair] += 1;
|
|
} else {
|
|
relocate(&counts)
|
|
RECORDDESCCOUNTS(rtd) = counts;
|
|
if (RTDCOUNTSTIMESTAMP(counts) != S_G.gctimestamp[0]) S_fixup_counts(counts);
|
|
}
|
|
RTDCOUNTSIT(counts, tg) += 1;
|
|
}
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
|
|
/* if the rtd is the only pointer and is immutable, put the record
|
|
into space data. if the record contains only pointers, put it
|
|
into space_pure or space_impure. otherwise put it into
|
|
space_pure_typed_object or space_impure_record. we could put all
|
|
records into space_{pure,impure}_record or even into
|
|
space_impure_record, but by picking the target space more
|
|
carefully we may reduce fragmentation and sweeping cost */
|
|
s = RECORDDESCPM(rtd) == FIX(1) && RECORDDESCMPM(rtd) == FIX(0) ?
|
|
space_data :
|
|
RECORDDESCPM(rtd) == FIX(-1) ?
|
|
RECORDDESCMPM(rtd) == FIX(0) ?
|
|
space_pure :
|
|
space_impure :
|
|
RECORDDESCMPM(rtd) == FIX(0) ?
|
|
space_pure_typed_object :
|
|
space_impure_record;
|
|
|
|
find_room(s, tg, type_typed_object, n, p);
|
|
copy_ptrs(type_typed_object, p, pp, n);
|
|
|
|
/* overwrite type field with forwarded descriptor */
|
|
RECORDINSTTYPE(p) = rtd == pp ? p : rtd;
|
|
|
|
/* pad if necessary */
|
|
if (s == space_pure || s == space_impure) {
|
|
iptr m = unaligned_size_record_inst(UNFIX(RECORDDESCSIZE(rtd)));
|
|
if (m != n)
|
|
*((ptr *)((uptr)UNTYPE(p,type_typed_object) + m)) = FIX(0);
|
|
}
|
|
} else if (TYPEP(tf, mask_fixnum, type_fixnum)) {
|
|
/* vector type/length field is a fixnum */
|
|
iptr len, n;
|
|
len = Svector_length(pp);
|
|
n = size_vector(len);
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_vector] += 1;
|
|
S_G.bytesof[tg][countof_vector] += n;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_impure, tg, type_typed_object, n, p);
|
|
copy_ptrs(type_typed_object, p, pp, n);
|
|
/* pad if necessary */
|
|
if ((len & 1) == 0) INITVECTIT(p, len) = FIX(0);
|
|
} else if (TYPEP(tf, mask_string, type_string)) {
|
|
iptr n;
|
|
n = size_string(Sstring_length(pp));
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_string] += 1;
|
|
S_G.bytesof[tg][countof_string] += n;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_data, tg, type_typed_object, n, p);
|
|
copy_ptrs(type_typed_object, p, pp, n);
|
|
} else if (TYPEP(tf, mask_fxvector, type_fxvector)) {
|
|
iptr n;
|
|
n = size_fxvector(Sfxvector_length(pp));
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_fxvector] += 1;
|
|
S_G.bytesof[tg][countof_fxvector] += n;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_data, tg, type_typed_object, n, p);
|
|
copy_ptrs(type_typed_object, p, pp, n);
|
|
} else if (TYPEP(tf, mask_bytevector, type_bytevector)) {
|
|
iptr n;
|
|
n = size_bytevector(Sbytevector_length(pp));
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_bytevector] += 1;
|
|
S_G.bytesof[tg][countof_bytevector] += n;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_data, tg, type_typed_object, n, p);
|
|
copy_ptrs(type_typed_object, p, pp, n);
|
|
} else if ((iptr)tf == type_tlc) {
|
|
ptr keyval, next;
|
|
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_tlc] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_impure, tg, type_typed_object, size_tlc, p);
|
|
TLCTYPE(p) = type_tlc;
|
|
INITTLCKEYVAL(p) = keyval = TLCKEYVAL(pp);
|
|
INITTLCHT(p) = TLCHT(pp);
|
|
INITTLCNEXT(p) = next = TLCNEXT(pp);
|
|
|
|
/* if next isn't false and keyval is old, add tlc to a list of tlcs
|
|
* to process later. determining if keyval is old is a (conservative)
|
|
* approximation to determining if key is old. we can't easily
|
|
* determine if key is old, since keyval might or might not have been
|
|
* swept already. NB: assuming keyvals are always pairs. */
|
|
if (next != Sfalse && SPACE(keyval) & space_old)
|
|
tlcs_to_rehash = S_cons_in(space_new, 0, p, tlcs_to_rehash);
|
|
} else if ((iptr)tf == type_box) {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_box] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_impure, tg, type_typed_object, size_box, p);
|
|
BOXTYPE(p) = type_box;
|
|
INITBOXREF(p) = Sunbox(pp);
|
|
} else if ((iptr)tf == type_ratnum) {
|
|
/* not recursive: place in space_data and relocate fields immediately */
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_ratnum] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_data, tg,
|
|
type_typed_object, size_ratnum, p);
|
|
RATTYPE(p) = type_ratnum;
|
|
RATNUM(p) = RATNUM(pp);
|
|
RATDEN(p) = RATDEN(pp);
|
|
relocate(&RATNUM(p))
|
|
relocate(&RATDEN(p))
|
|
} else if ((iptr)tf == type_exactnum) {
|
|
/* not recursive: place in space_data and relocate fields immediately */
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_exactnum] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_data, tg,
|
|
type_typed_object, size_exactnum, p);
|
|
EXACTNUM_TYPE(p) = type_exactnum;
|
|
EXACTNUM_REAL_PART(p) = EXACTNUM_REAL_PART(pp);
|
|
EXACTNUM_IMAG_PART(p) = EXACTNUM_IMAG_PART(pp);
|
|
relocate(&EXACTNUM_REAL_PART(p))
|
|
relocate(&EXACTNUM_IMAG_PART(p))
|
|
} else if ((iptr)tf == type_inexactnum) {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_inexactnum] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_data, tg,
|
|
type_typed_object, size_inexactnum, p);
|
|
INEXACTNUM_TYPE(p) = type_inexactnum;
|
|
INEXACTNUM_REAL_PART(p) = INEXACTNUM_REAL_PART(pp);
|
|
INEXACTNUM_IMAG_PART(p) = INEXACTNUM_IMAG_PART(pp);
|
|
} else if (TYPEP(tf, mask_bignum, type_bignum)) {
|
|
iptr n;
|
|
n = size_bignum(BIGLEN(pp));
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_bignum] += 1;
|
|
S_G.bytesof[tg][countof_bignum] += n;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_data, tg, type_typed_object, n, p);
|
|
copy_ptrs(type_typed_object, p, pp, n);
|
|
} else if (TYPEP(tf, mask_port, type_port)) {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_port] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_port, tg,
|
|
type_typed_object, size_port, p);
|
|
PORTTYPE(p) = PORTTYPE(pp);
|
|
PORTHANDLER(p) = PORTHANDLER(pp);
|
|
PORTNAME(p) = PORTNAME(pp);
|
|
PORTINFO(p) = PORTINFO(pp);
|
|
PORTOCNT(p) = PORTOCNT(pp);
|
|
PORTICNT(p) = PORTICNT(pp);
|
|
PORTOBUF(p) = PORTOBUF(pp);
|
|
PORTOLAST(p) = PORTOLAST(pp);
|
|
PORTIBUF(p) = PORTIBUF(pp);
|
|
PORTILAST(p) = PORTILAST(pp);
|
|
} else if (TYPEP(tf, mask_code, type_code)) {
|
|
iptr n;
|
|
n = size_code(CODELEN(pp));
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_code] += 1;
|
|
S_G.bytesof[tg][countof_code] += n;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_code, tg, type_typed_object, n, p);
|
|
copy_ptrs(type_typed_object, p, pp, n);
|
|
} else if ((iptr)tf == type_thread) {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_thread] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_pure_typed_object, tg,
|
|
type_typed_object, size_thread, p);
|
|
TYPEFIELD(p) = (ptr)type_thread;
|
|
THREADTC(p) = THREADTC(pp); /* static */
|
|
} else if ((iptr)tf == type_rtd_counts) {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_rtd_counts] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_data, tg, type_typed_object, size_rtd_counts, p);
|
|
copy_ptrs(type_typed_object, p, pp, size_rtd_counts);
|
|
} else {
|
|
S_error_abort("copy(gc): illegal type");
|
|
return (ptr)0 /* not reached */;
|
|
}
|
|
} else if (t == type_pair) {
|
|
ptr qq = Scdr(pp); ptr q; seginfo *si;
|
|
if (qq != pp && TYPEBITS(qq) == type_pair && (si = MaybeSegInfo(ptr_get_segment(qq))) != NULL && si->space == pps && FWDMARKER(qq) != forward_marker && !locked(qq)) {
|
|
if (pps == (space_weakpair | space_old)) {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_weakpair] += 2;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_weakpair, tg, type_pair, 2 * size_pair, p);
|
|
} else {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_pair] += 2;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_impure, tg, type_pair, 2 * size_pair, p);
|
|
}
|
|
q = (ptr)((uptr)p + size_pair);
|
|
INITCAR(p) = Scar(pp);
|
|
INITCDR(p) = q;
|
|
INITCAR(q) = Scar(qq);
|
|
INITCDR(q) = Scdr(qq);
|
|
FWDMARKER(qq) = forward_marker;
|
|
FWDADDRESS(qq) = q;
|
|
} else {
|
|
if (pps == (space_weakpair | space_old)) {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_weakpair] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_weakpair, tg, type_pair, size_pair, p);
|
|
} else {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_pair] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_impure, tg, type_pair, size_pair, p);
|
|
}
|
|
INITCAR(p) = Scar(pp);
|
|
INITCDR(p) = qq;
|
|
}
|
|
} else if (t == type_closure) {
|
|
ptr code;
|
|
|
|
/* relocate before accessing code type field, which otherwise might
|
|
be a forwarding marker */
|
|
code = CLOSCODE(pp);
|
|
relocate(&code)
|
|
if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_continuation] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_continuation, tg,
|
|
type_closure, size_continuation, p);
|
|
SETCLOSCODE(p,code);
|
|
/* don't promote one-shots */
|
|
CONTLENGTH(p) = CONTLENGTH(pp);
|
|
CONTCLENGTH(p) = CONTCLENGTH(pp);
|
|
CONTWINDERS(p) = CONTWINDERS(pp);
|
|
if (CONTLENGTH(p) != scaled_shot_1_shot_flag) {
|
|
CONTLINK(p) = CONTLINK(pp);
|
|
CONTRET(p) = CONTRET(pp);
|
|
CONTSTACK(p) = CONTSTACK(pp);
|
|
}
|
|
} else {
|
|
iptr len, n;
|
|
len = CLOSLEN(pp);
|
|
n = size_closure(len);
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_closure] += 1;
|
|
S_G.bytesof[tg][countof_closure] += n;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_pure, tg, type_closure, n, p);
|
|
copy_ptrs(type_closure, p, pp, n);
|
|
SETCLOSCODE(p,code);
|
|
/* pad if necessary */
|
|
if ((len & 1) == 0) CLOSIT(p, len) = FIX(0);
|
|
}
|
|
} else if (t == type_symbol) {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_symbol] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_symbol, tg, type_symbol, size_symbol, p);
|
|
INITSYMVAL(p) = SYMVAL(pp);
|
|
INITSYMPVAL(p) = SYMPVAL(pp);
|
|
INITSYMPLIST(p) = SYMPLIST(pp);
|
|
INITSYMSPLIST(p) = SYMSPLIST(pp);
|
|
INITSYMNAME(p) = SYMNAME(pp);
|
|
INITSYMHASH(p) = SYMHASH(pp);
|
|
} else if (t == type_flonum) {
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_flonum] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_data, tg, type_flonum, size_flonum, p);
|
|
FLODAT(p) = FLODAT(pp);
|
|
/* no room for forwarding address, so let 'em be duplicated */
|
|
return p;
|
|
} else {
|
|
S_error_abort("copy(gc): illegal type");
|
|
return (ptr)0 /* not reached */;
|
|
}
|
|
|
|
FWDMARKER(pp) = forward_marker;
|
|
FWDADDRESS(pp) = p;
|
|
|
|
return p;
|
|
}
|
|
|
|
static void sweep_ptrs(pp, n) ptr *pp; iptr n; {
|
|
ptr *end = pp + n;
|
|
|
|
while (pp != end) {
|
|
relocate(pp)
|
|
pp += 1;
|
|
}
|
|
}
|
|
|
|
static void sweep(ptr tc, ptr p, IBOOL sweep_pure) {
|
|
ptr tf; ITYPE t;
|
|
|
|
if ((t = TYPEBITS(p)) == type_pair) {
|
|
if ((SPACE(p) & ~(space_locked | space_old)) != space_weakpair) {
|
|
relocate(&INITCAR(p))
|
|
}
|
|
relocate(&INITCDR(p))
|
|
} else if (t == type_closure) {
|
|
if (sweep_pure) {
|
|
ptr code;
|
|
|
|
code = CLOSCODE(p);
|
|
relocate(&code)
|
|
SETCLOSCODE(p,code);
|
|
if (CODETYPE(code) & (code_flag_continuation << code_flags_offset))
|
|
sweep_continuation(p);
|
|
else
|
|
sweep_ptrs(&CLOSIT(p, 0), CLOSLEN(p));
|
|
}
|
|
} else if (t == type_symbol) {
|
|
sweep_symbol(p);
|
|
} else if (t == type_flonum) {
|
|
/* nothing to sweep */;
|
|
/* typed objects */
|
|
} else if (tf = TYPEFIELD(p), TYPEP(tf, mask_fixnum, type_fixnum)) {
|
|
sweep_ptrs(&INITVECTIT(p, 0), UNFIX(tf));
|
|
} else if (TYPEP(tf, mask_string, type_string) || TYPEP(tf, mask_bytevector, type_bytevector) || TYPEP(tf, mask_fxvector, type_fxvector)) {
|
|
/* nothing to sweep */;
|
|
} else if (TYPEP(tf, mask_record, type_record)) {
|
|
relocate(&RECORDINSTTYPE(p));
|
|
if (sweep_pure || RECORDDESCMPM(RECORDINSTTYPE(p)) != FIX(0)) {
|
|
sweep_record(p);
|
|
}
|
|
} else if ((iptr)tf == type_box) {
|
|
relocate(&INITBOXREF(p))
|
|
} else if ((iptr)tf == type_ratnum) {
|
|
if (sweep_pure) {
|
|
relocate(&RATNUM(p))
|
|
relocate(&RATDEN(p))
|
|
}
|
|
} else if ((iptr)tf == type_exactnum) {
|
|
if (sweep_pure) {
|
|
relocate(&EXACTNUM_REAL_PART(p))
|
|
relocate(&EXACTNUM_IMAG_PART(p))
|
|
}
|
|
} else if ((iptr)tf == type_inexactnum) {
|
|
/* nothing to sweep */;
|
|
} else if (TYPEP(tf, mask_bignum, type_bignum)) {
|
|
/* nothing to sweep */;
|
|
} else if (TYPEP(tf, mask_port, type_port)) {
|
|
sweep_port(p);
|
|
} else if (TYPEP(tf, mask_code, type_code)) {
|
|
if (sweep_pure) {
|
|
sweep_code_object(tc, p);
|
|
}
|
|
} else if ((iptr)tf == type_thread) {
|
|
sweep_thread(p);
|
|
} else if ((iptr)tf == type_rtd_counts) {
|
|
/* nothing to sweep */;
|
|
} else {
|
|
S_error_abort("sweep(gc): illegal type");
|
|
}
|
|
}
|
|
|
|
static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; {
|
|
iptr n, m; ptr new;
|
|
|
|
/* Don't copy non-oldspace stacks, since we may be sweeping a locked
|
|
continuation that is older than target_generation. Doing so would
|
|
be a waste of work anyway. */
|
|
if (!OLDSPACE(old)) return old;
|
|
|
|
/* reduce headroom created for excessively large frames (typically resulting from apply with long lists) */
|
|
if ((n = *length) != clength && n > default_stack_size && n > (m = clength + one_shot_headroom)) {
|
|
*length = n = m;
|
|
}
|
|
|
|
n = ptr_align(n);
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[target_generation][countof_stack] += 1;
|
|
S_G.bytesof[target_generation][countof_stack] += n;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_data, target_generation, typemod, n, new);
|
|
n = ptr_align(clength);
|
|
/* warning: stack may have been left non-double-aligned by split_and_resize */
|
|
copy_ptrs(typemod, new, old, n);
|
|
|
|
/* also returning possibly updated value in *length */
|
|
return new;
|
|
}
|
|
|
|
#define NONSTATICINHEAP(si, x) (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && si->generation != static_generation)
|
|
#define ALWAYSTRUE(si, x) (si = SegInfo(ptr_get_segment(x)), 1)
|
|
#define partition_guardians(LS, FILTER) { \
|
|
ptr ls; seginfo *si;\
|
|
for (ls = LS; ls != Snil; ls = next) { \
|
|
obj = GUARDIANOBJ(ls); \
|
|
next = GUARDIANNEXT(ls); \
|
|
\
|
|
if (FILTER(si, obj)) { \
|
|
if (!(si->space & space_old) || locked(obj)) { \
|
|
INITGUARDIANNEXT(ls) = pend_hold_ls; \
|
|
pend_hold_ls = ls; \
|
|
} else if (FWDMARKER(obj) == forward_marker && TYPEBITS(obj) != type_flonum) { \
|
|
INITGUARDIANOBJ(ls) = FWDADDRESS(obj); \
|
|
INITGUARDIANNEXT(ls) = pend_hold_ls; \
|
|
pend_hold_ls = ls; \
|
|
} else { \
|
|
tconc = GUARDIANTCONC(ls); \
|
|
if (!OLDSPACE(tconc) || locked(tconc)) { \
|
|
INITGUARDIANNEXT(ls) = final_ls; \
|
|
final_ls = ls; \
|
|
} else if (FWDMARKER(tconc) == forward_marker) { \
|
|
INITGUARDIANTCONC(ls) = FWDADDRESS(tconc); \
|
|
INITGUARDIANNEXT(ls) = final_ls; \
|
|
final_ls = ls; \
|
|
} else { \
|
|
INITGUARDIANNEXT(ls) = pend_final_ls; \
|
|
pend_final_ls = ls; \
|
|
} \
|
|
} \
|
|
} \
|
|
} \
|
|
}
|
|
|
|
void GCENTRY(ptr tc, IGEN mcg, IGEN tg) {
|
|
IGEN g; ISPC s;
|
|
seginfo *oldspacesegments, *si, *nextsi;
|
|
ptr ls;
|
|
bucket_pointer_list *buckets_to_rebuild;
|
|
ptr locked_oldspace_objects;
|
|
|
|
/* flush instruction cache: effectively clear_code_mod but safer */
|
|
for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
|
|
ptr tc = (ptr)THREADTC(Scar(ls));
|
|
S_flush_instruction_cache(tc);
|
|
}
|
|
|
|
tlcs_to_rehash = Snil;
|
|
|
|
for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
|
|
ptr tc = (ptr)THREADTC(Scar(ls));
|
|
S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc));
|
|
EAP(tc) = REAL_EAP(tc) = AP(tc) = (ptr)0;
|
|
}
|
|
|
|
/* perform after ScanDirty */
|
|
if (S_checkheap) S_check_heap(0);
|
|
|
|
#ifdef DEBUG
|
|
(void)printf("mcg = %x; go? ", mcg); (void)fflush(stdout); (void)getc(stdin);
|
|
#endif
|
|
|
|
target_generation = tg;
|
|
max_copied_generation = mcg;
|
|
|
|
/* set up generations to be copied */
|
|
for (s = 0; s <= max_real_space; s++)
|
|
for (g = 0; g <= mcg; 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;
|
|
}
|
|
|
|
/* set up target generation sweep_loc and orig_next_loc pointers */
|
|
for (s = 0; s <= max_real_space; s++)
|
|
orig_next_loc[s] = sweep_loc[s] = S_G.next_loc[s][tg];
|
|
|
|
/* mark segments from which objects are to be copied */
|
|
oldspacesegments = (seginfo *)NULL;
|
|
for (s = 0; s <= max_real_space; s += 1) {
|
|
for (g = 0; g <= mcg; g += 1) {
|
|
for (si = S_G.occupied_segments[s][g]; si != NULL; si = nextsi) {
|
|
nextsi = si->next;
|
|
si->next = oldspacesegments;
|
|
oldspacesegments = si;
|
|
si->space = s | space_old; /* NB: implicitly clearing space_locked */
|
|
}
|
|
S_G.occupied_segments[s][g] = NULL;
|
|
}
|
|
}
|
|
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
/* clear object counts & bytes for copied generations; bump timestamp */
|
|
{INT i;
|
|
for (g = 0; g <= mcg; g += 1) {
|
|
for (i = 0; i < countof_types; i += 1) {
|
|
S_G.countof[g][i] = 0;
|
|
S_G.bytesof[g][i] = 0;
|
|
}
|
|
if (g == 0) {
|
|
S_G.gctimestamp[g] += 1;
|
|
} else {
|
|
S_G.gctimestamp[g] = S_G.gctimestamp[0];
|
|
}
|
|
}
|
|
}
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
|
|
/* pre-collection handling of locked objects. */
|
|
|
|
/* create a single sorted_locked_object vector for all copied generations
|
|
* to accelerate the search for locked objects in copy(). copy wants
|
|
* a vector of some size n=2^k-1 so it doesn't have to check bounds */
|
|
ls = Snil;
|
|
/* note: append_bang and dosort reuse pairs, which can result in older
|
|
* objects pointing to newer ones...but we don't care since they are all
|
|
* oldspace and going away after this collection. */
|
|
for (g = 0; g <= mcg; g += 1) {
|
|
ls = append_bang(S_G.locked_objects[g], ls);
|
|
S_G.locked_objects[g] = Snil;
|
|
S_G.unlocked_objects[g] = Snil;
|
|
}
|
|
if (ls == Snil) {
|
|
sorted_locked_objects = FIX(0);
|
|
locked_oldspace_objects = Snil;
|
|
} else {
|
|
ptr v, x, y; uptr i, n;
|
|
|
|
/* dosort is destructive, so have to store the result back */
|
|
locked_oldspace_objects = ls = dosort(ls, list_length(ls));
|
|
|
|
/* create vector of smallest size n=2^k-1 that will fit all of
|
|
the list's unique elements */
|
|
i = count_unique(ls);
|
|
for (n = 1; n < i; n = (n << 1) | 1);
|
|
sorted_locked_objects = v = S_vector_in(space_new, 0, n);
|
|
|
|
/* copy list elements in, skipping duplicates */
|
|
INITVECTIT(v,0) = x = Scar(ls);
|
|
i = 1;
|
|
while ((ls = Scdr(ls)) != Snil) {
|
|
if ((y = Scar(ls)) != x) {
|
|
INITVECTIT(v, i) = x = y;
|
|
i += 1;
|
|
}
|
|
}
|
|
|
|
/* fill remaining slots with largest ptr value */
|
|
while (i < n) { INITVECTIT(v, i) = MAXPTR; i += 1; }
|
|
}
|
|
|
|
/* sweep older locked and unlocked objects */
|
|
for (g = mcg + 1; g <= static_generation; INCRGEN(g)) {
|
|
for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls))
|
|
sweep(tc, Scar(ls), 0);
|
|
for (ls = S_G.unlocked_objects[g]; ls != Snil; ls = Scdr(ls))
|
|
sweep(tc, Scar(ls), 0);
|
|
}
|
|
|
|
/* sweep younger locked objects, working from sorted vector to avoid redundant sweeping of duplicates */
|
|
if (sorted_locked_objects != FIX(0)) {
|
|
uptr i; ptr x, v, *vp;
|
|
v = sorted_locked_objects;
|
|
i = Svector_length(v);
|
|
x = *(vp = &INITVECTIT(v, 0));
|
|
do sweep(tc, x, 1); while (--i != 0 && (x = *++vp) != MAXPTR);
|
|
}
|
|
/* sweep non-oldspace threads, since any thread may have an active stack */
|
|
for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
|
|
ptr thread;
|
|
|
|
/* someone may have their paws on the list */
|
|
if (FWDMARKER(ls) == forward_marker) ls = FWDADDRESS(ls);
|
|
|
|
thread = Scar(ls);
|
|
if (!OLDSPACE(thread)) sweep_thread(thread);
|
|
}
|
|
relocate(&S_threads)
|
|
|
|
/* relocate nonempty oldspace symbols and set up list of buckets to rebuild later */
|
|
buckets_to_rebuild = NULL;
|
|
for (g = 0; g <= mcg; g += 1) {
|
|
bucket_list *bl, *blnext; bucket *b; bucket_pointer_list *bpl; bucket **oblist_cell; ptr sym; iptr idx;
|
|
for (bl = S_G.buckets_of_generation[g]; bl != NULL; bl = blnext) {
|
|
blnext = bl->cdr;
|
|
b = bl->car;
|
|
/* mark this bucket old for the rebuilding loop */
|
|
b->next = (bucket *)((uptr)b->next | 1);
|
|
sym = b->sym;
|
|
idx = UNFIX(SYMHASH(sym)) % S_G.oblist_length;
|
|
oblist_cell = &S_G.oblist[idx];
|
|
if (!((uptr)*oblist_cell & 1)) {
|
|
/* mark this bucket in the set */
|
|
*oblist_cell = (bucket *)((uptr)*oblist_cell | 1);
|
|
/* repurpose the bucket list element for the list of buckets to rebuild later */
|
|
/* idiot_checks verifies these have the same size */
|
|
bpl = (bucket_pointer_list *)bl;
|
|
bpl->car = oblist_cell;
|
|
bpl->cdr = buckets_to_rebuild;
|
|
buckets_to_rebuild = bpl;
|
|
}
|
|
if (FWDMARKER(sym) != forward_marker &&
|
|
/* coordinate with alloc.c */
|
|
(SYMVAL(sym) != sunbound || SYMPLIST(sym) != Snil || SYMSPLIST(sym) != Snil))
|
|
(void)copy(sym, SPACE(sym));
|
|
}
|
|
S_G.buckets_of_generation[g] = NULL;
|
|
}
|
|
|
|
/* relocate the protected C pointers */
|
|
{uptr i;
|
|
for (i = 0; i < S_G.protect_next; i++)
|
|
relocate(S_G.protected[i])
|
|
}
|
|
|
|
/* sweep areas marked dirty by assignments into older generations */
|
|
sweep_dirty();
|
|
|
|
sweep_generation(tc, tg);
|
|
|
|
/* handle guardians */
|
|
{ ptr hold_ls, pend_hold_ls, final_ls, pend_final_ls;
|
|
ptr obj, rep, tconc, next;
|
|
|
|
/* move each entry in guardian lists into one of:
|
|
* pend_hold_ls if obj accessible
|
|
* final_ls if obj not accessible and tconc accessible
|
|
* pend_final_ls if obj not accessible and tconc not accessible */
|
|
pend_hold_ls = final_ls = pend_final_ls = Snil;
|
|
|
|
for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
|
|
ptr tc = (ptr)THREADTC(Scar(ls));
|
|
partition_guardians(GUARDIANENTRIES(tc), NONSTATICINHEAP);
|
|
GUARDIANENTRIES(tc) = Snil;
|
|
}
|
|
|
|
for (g = 0; g <= mcg; g += 1) {
|
|
partition_guardians(S_G.guardians[g], ALWAYSTRUE);
|
|
S_G.guardians[g] = Snil;
|
|
}
|
|
|
|
/* invariants after partition_guardians:
|
|
* for entry in pend_hold_ls, obj is !OLDSPACE or locked
|
|
* for entry in final_ls, obj is OLDSPACE and !locked
|
|
* for entry in final_ls, tconc is !OLDSPACE or locked
|
|
* for entry in pend_final_ls, obj and tconc are OLDSPACE and !locked
|
|
*/
|
|
|
|
hold_ls = S_G.guardians[tg];
|
|
while (1) {
|
|
IBOOL relocate_rep = final_ls != Snil;
|
|
|
|
/* relocate & add the final objects to their tconcs */
|
|
for (ls = final_ls; ls != Snil; ls = GUARDIANNEXT(ls)) {
|
|
ptr old_end, new_end;
|
|
|
|
rep = GUARDIANREP(ls);
|
|
relocate(&rep);
|
|
|
|
/* if tconc was old it's been forwarded */
|
|
tconc = GUARDIANTCONC(ls);
|
|
|
|
old_end = Scdr(tconc);
|
|
/* allocating pair in tg means it will be swept, which is wasted effort, but should cause no harm */
|
|
new_end = S_cons_in(space_impure, tg, FIX(0), FIX(0));
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_pair] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
|
|
SETCAR(old_end,rep);
|
|
SETCDR(old_end,new_end);
|
|
SETCDR(tconc,new_end);
|
|
}
|
|
|
|
/* discard static pend_hold_ls entries */
|
|
if (tg != static_generation) {
|
|
/* copy each entry in pend_hold_ls into hold_ls if tconc accessible */
|
|
ls = pend_hold_ls; pend_hold_ls = Snil;
|
|
for ( ; ls != Snil; ls = next) {
|
|
tconc = GUARDIANTCONC(ls); next = GUARDIANNEXT(ls); ptr p;
|
|
|
|
if (OLDSPACE(tconc) && !locked(tconc)) {
|
|
if (FWDMARKER(tconc) == forward_marker)
|
|
tconc = FWDADDRESS(tconc);
|
|
else {
|
|
INITGUARDIANNEXT(ls) = pend_hold_ls;
|
|
pend_hold_ls = ls;
|
|
continue;
|
|
}
|
|
}
|
|
|
|
rep = GUARDIANREP(ls);
|
|
relocate(&rep);
|
|
relocate_rep = 1;
|
|
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_guardian] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_pure, tg, typemod, size_guardian_entry, p);
|
|
INITGUARDIANOBJ(p) = GUARDIANOBJ(ls);
|
|
INITGUARDIANREP(p) = rep;
|
|
INITGUARDIANTCONC(p) = tconc;
|
|
INITGUARDIANNEXT(p) = hold_ls;
|
|
hold_ls = p;
|
|
}
|
|
}
|
|
|
|
if (!relocate_rep) break;
|
|
|
|
sweep_generation(tc, tg);
|
|
|
|
/* move each entry in pend_final_ls into one of:
|
|
* final_ls if tconc forwarded
|
|
* pend_final_ls if tconc not forwarded */
|
|
ls = pend_final_ls; final_ls = pend_final_ls = Snil;
|
|
for ( ; ls != Snil; ls = next) {
|
|
tconc = GUARDIANTCONC(ls); next = GUARDIANNEXT(ls);
|
|
|
|
if (FWDMARKER(tconc) == forward_marker) {
|
|
INITGUARDIANTCONC(ls) = FWDADDRESS(tconc);
|
|
INITGUARDIANNEXT(ls) = final_ls;
|
|
final_ls = ls;
|
|
} else {
|
|
INITGUARDIANNEXT(ls) = pend_final_ls;
|
|
pend_final_ls = ls;
|
|
}
|
|
}
|
|
}
|
|
|
|
S_G.guardians[tg] = hold_ls;
|
|
}
|
|
|
|
/* handle weak pairs */
|
|
resweep_dirty_weak_pairs();
|
|
resweep_weak_pairs(tg);
|
|
|
|
/* forward car fields of locked and unlocked older weak pairs */
|
|
for (g = mcg + 1; g <= static_generation; INCRGEN(g)) {
|
|
for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) {
|
|
ptr x = Scar(ls);
|
|
if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair)
|
|
forward_or_bwp(&INITCAR(x), Scar(x));
|
|
}
|
|
for (ls = S_G.unlocked_objects[g]; ls != Snil; ls = Scdr(ls)) {
|
|
ptr x = Scar(ls);
|
|
if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair)
|
|
forward_or_bwp(&INITCAR(x), Scar(x));
|
|
}
|
|
}
|
|
|
|
/* forward car fields of locked oldspace weak pairs */
|
|
if (sorted_locked_objects != FIX(0)) {
|
|
uptr i; ptr x, v, *vp;
|
|
v = sorted_locked_objects;
|
|
i = Svector_length(v);
|
|
x = *(vp = &INITVECTIT(v, 0));
|
|
do {
|
|
if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair) {
|
|
forward_or_bwp(&INITCAR(x), Scar(x));
|
|
}
|
|
} while (--i != 0 && (x = *++vp) != MAXPTR);
|
|
}
|
|
|
|
/* post-gc oblist handling. rebuild old buckets in the target generation, pruning unforwarded symbols */
|
|
{ bucket_list *bl, *blnext; bucket *b, *bnext; bucket_pointer_list *bpl; bucket **pb; ptr sym;
|
|
bl = tg == static_generation ? NULL : S_G.buckets_of_generation[tg];
|
|
for (bpl = buckets_to_rebuild; bpl != NULL; bpl = bpl->cdr) {
|
|
pb = bpl->car;
|
|
for (b = (bucket *)((uptr)*pb - 1); b != NULL && ((uptr)(b->next) & 1); b = bnext) {
|
|
bnext = (bucket *)((uptr)(b->next) - 1);
|
|
sym = b->sym;
|
|
if (locked(sym) || (FWDMARKER(sym) == forward_marker && ((sym = FWDADDRESS(sym)) || 1))) {
|
|
find_room(space_data, tg, typemod, sizeof(bucket), b);
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_oblist] += 1;
|
|
S_G.bytesof[tg][countof_oblist] += sizeof(bucket);
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
b->sym = sym;
|
|
*pb = b;
|
|
pb = &b->next;
|
|
if (tg != static_generation) {
|
|
blnext = bl;
|
|
find_room(space_data, tg, typemod, sizeof(bucket_list), bl);
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_oblist] += 1;
|
|
S_G.bytesof[tg][countof_oblist] += sizeof(bucket_list);
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
bl->cdr = blnext;
|
|
bl->car = b;
|
|
}
|
|
} else {
|
|
S_G.oblist_count -= 1;
|
|
}
|
|
}
|
|
*pb = b;
|
|
}
|
|
if (tg != static_generation) S_G.buckets_of_generation[tg] = bl;
|
|
}
|
|
|
|
/* rebuild rtds_with_counts lists, dropping otherwise inaccessible rtds */
|
|
{ IGEN g; ptr ls, p, newls = tg == mcg ? Snil : S_G.rtds_with_counts[tg];
|
|
for (g = 0; g <= mcg; g += 1) {
|
|
for (ls = S_G.rtds_with_counts[g], S_G.rtds_with_counts[g] = Snil; ls != Snil; ls = Scdr(ls)) {
|
|
p = Scar(ls);
|
|
if (!OLDSPACE(p) || locked(p)) {
|
|
newls = S_cons_in(space_impure, tg, p, newls);
|
|
S_G.countof[tg][countof_pair] += 1;
|
|
} else if (FWDMARKER(p) == forward_marker) {
|
|
newls = S_cons_in(space_impure, tg, FWDADDRESS(p), newls);
|
|
S_G.countof[tg][countof_pair] += 1;
|
|
}
|
|
}
|
|
}
|
|
S_G.rtds_with_counts[tg] = newls;
|
|
}
|
|
|
|
#ifndef WIN32
|
|
/* rebuild child_process list, reaping any that have died and refusing
|
|
to promote into the static generation. */
|
|
{
|
|
ptr old_ls, new_ls; IGEN gtmp, cpgen;
|
|
cpgen = tg == static_generation ? S_G.max_nonstatic_generation : tg;
|
|
new_ls = cpgen <= mcg ? Snil : S_child_processes[cpgen];
|
|
for (gtmp = 0; gtmp <= mcg; gtmp += 1) {
|
|
for (old_ls = S_child_processes[gtmp]; old_ls != Snil; old_ls = Scdr(old_ls)) {
|
|
INT pid = UNFIX(Scar(old_ls)), status, retpid;
|
|
retpid = waitpid(pid, &status, WNOHANG);
|
|
if (retpid == 0 || (retpid == pid && !(WIFEXITED(status) || WIFSIGNALED(status)))) {
|
|
new_ls = S_cons_in(space_impure, cpgen, FIX(pid), new_ls);
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[cpgen][countof_pair] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
}
|
|
}
|
|
S_child_processes[gtmp] = Snil;
|
|
}
|
|
S_child_processes[cpgen] = new_ls;
|
|
}
|
|
#endif /* WIN32 */
|
|
|
|
/* post-collection handling of locked objects. This must come after
|
|
any use of relocate or any other use of sorted_locked_objects */
|
|
if (sorted_locked_objects != FIX(0)) {
|
|
ptr ls, lsnew, x, v, *vp; iptr i;
|
|
|
|
v = sorted_locked_objects;
|
|
lsnew = tg == mcg ? Snil : S_G.locked_objects[tg];
|
|
|
|
/* work from sorted vector to avoid redundant processing of duplicates */
|
|
i = Svector_length(v);
|
|
x = *(vp = &INITVECTIT(v, 0));
|
|
do {
|
|
ptr a1, a2; uptr seg; uptr n;
|
|
|
|
/* promote the segment(s) containing x to the target generation.
|
|
reset the space_old bit to prevent the segments from being
|
|
reclaimed; set the locked bit to prevent sweeping by
|
|
sweep_dirty (since the segments may contain a mix of objects,
|
|
many of which have been discarded). */
|
|
n = size_object(x);
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[target_generation][countof_locked] += 1;
|
|
S_G.bytesof[target_generation][countof_locked] += n;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
|
|
a1 = UNTYPE_ANY(x);
|
|
a2 = (ptr)((uptr)a1 + n - 1);
|
|
for (seg = addr_get_segment(a1); seg <= addr_get_segment(a2); seg += 1) {
|
|
seginfo *si = SegInfo(seg);
|
|
si->generation = tg;
|
|
si->space = (si->space & ~space_old) | space_locked;
|
|
}
|
|
} while (--i != 0 && (x = *++vp) != MAXPTR);
|
|
|
|
/* append entire list, including duplicates, to target-generation list. we do so
|
|
even when tg == static_generation so we can keep track of static objects that need to
|
|
be swept at the start of collection. (we could weed out pure static objects.) */
|
|
for (ls = locked_oldspace_objects; ls != Snil; ls = Scdr(ls)) {
|
|
lsnew = S_cons_in(space_impure, tg, Scar(ls), lsnew);
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[tg][countof_pair] += 1;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
}
|
|
|
|
S_G.locked_objects[tg] = lsnew;
|
|
}
|
|
|
|
/* move old space segments to empty space */
|
|
for (si = oldspacesegments; si != NULL; si = nextsi) {
|
|
nextsi = si->next;
|
|
s = si->space;
|
|
if (s & space_locked) {
|
|
/* note: the oldspace bit is cleared above for locked objects */
|
|
s &= ~space_locked;
|
|
g = si->generation;
|
|
if (g == static_generation) S_G.number_of_nonstatic_segments -= 1;
|
|
si->next = S_G.occupied_segments[s][g];
|
|
S_G.occupied_segments[s][g] = si;
|
|
} else {
|
|
chunkinfo *chunk = si->chunk;
|
|
if (si->generation != static_generation) S_G.number_of_nonstatic_segments -= 1;
|
|
S_G.number_of_empty_segments += 1;
|
|
si->space = space_empty;
|
|
si->next = chunk->unused_segs;
|
|
chunk->unused_segs = si;
|
|
#ifdef WIPECLEAN
|
|
memset((void *)build_ptr(seg,0), 0xc7, bytes_per_segment);
|
|
#endif
|
|
if ((chunk->nused_segs -= 1) == 0) {
|
|
if (chunk->bytes != (minimum_segment_request + 1) * bytes_per_segment) {
|
|
/* release oversize chunks back to the O/S immediately to avoid allocating
|
|
* small stuff into them and thereby invite fragmentation */
|
|
S_free_chunk(chunk);
|
|
} else {
|
|
S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS]);
|
|
}
|
|
} else {
|
|
S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]);
|
|
}
|
|
}
|
|
}
|
|
|
|
if (mcg >= S_G.min_free_gen) S_free_chunks();
|
|
|
|
S_flush_instruction_cache(tc);
|
|
|
|
if (S_checkheap) S_check_heap(1);
|
|
|
|
/* post-collection rehashing of tlcs.
|
|
must come after any use of relocate.
|
|
logically comes after gc is entirely complete */
|
|
while (tlcs_to_rehash != Snil) {
|
|
ptr b, next; uptr old_idx, new_idx;
|
|
ptr tlc = Scar(tlcs_to_rehash);
|
|
ptr ht = TLCHT(tlc);
|
|
ptr vec = PTRFIELD(ht,eq_hashtable_vec_disp);
|
|
uptr veclen = Svector_length(vec);
|
|
ptr key = Scar(TLCKEYVAL(tlc));
|
|
|
|
/* scan to end of bucket to find the index */
|
|
for (b = TLCNEXT(tlc); !Sfixnump(b); b = TLCNEXT(b));
|
|
old_idx = UNFIX(b);
|
|
|
|
if (key == Sbwp_object && PTRFIELD(ht,eq_hashtable_weakp_disp) != Sfalse) {
|
|
/* remove tlc */
|
|
b = Svector_ref(vec, old_idx);
|
|
if (b == tlc) {
|
|
SETVECTIT(vec, old_idx, TLCNEXT(b));
|
|
} else {
|
|
for (;;) { next = TLCNEXT(b); if (next == tlc) break; b = next; }
|
|
SETTLCNEXT(b,TLCNEXT(next));
|
|
}
|
|
INITTLCNEXT(tlc) = Sfalse;
|
|
INITPTRFIELD(ht,eq_hashtable_size_disp) = FIX(UNFIX(PTRFIELD(ht,eq_hashtable_size_disp)) - 1);
|
|
} else if ((new_idx = ((uptr)key >> primary_type_bits) & (veclen - 1)) != old_idx) {
|
|
/* remove tlc from old bucket */
|
|
b = Svector_ref(vec, old_idx);
|
|
if (b == tlc) {
|
|
SETVECTIT(vec, old_idx, TLCNEXT(b));
|
|
} else {
|
|
for (;;) { next = TLCNEXT(b); if (next == tlc) break; b = next; }
|
|
SETTLCNEXT(b,TLCNEXT(next));
|
|
}
|
|
/* and add to new bucket */
|
|
SETTLCNEXT(tlc, Svector_ref(vec, new_idx));
|
|
SETVECTIT(vec, new_idx, tlc);
|
|
}
|
|
tlcs_to_rehash = Scdr(tlcs_to_rehash);
|
|
}
|
|
|
|
S_resize_oblist();
|
|
}
|
|
|
|
#define sweep_space(s, body)\
|
|
slp = &sweep_loc[s];\
|
|
nlp = &S_G.next_loc[s][g];\
|
|
if (*slp == 0) *slp = S_G.first_loc[s][g];\
|
|
pp = (ptr *)*slp;\
|
|
while (pp != (nl = (ptr *)*nlp))\
|
|
do\
|
|
if ((p = *pp) == forward_marker)\
|
|
pp = (ptr *)*(pp + 1);\
|
|
else\
|
|
body\
|
|
while (pp != nl);\
|
|
*slp = (ptr)pp;
|
|
|
|
static void resweep_weak_pairs(g) IGEN g; {
|
|
ptr *slp, *nlp; ptr *pp, p, *nl;
|
|
|
|
sweep_loc[space_weakpair] = S_G.first_loc[space_weakpair][g];
|
|
sweep_space(space_weakpair, {
|
|
forward_or_bwp(pp, p);
|
|
pp += 2;
|
|
})
|
|
}
|
|
|
|
static void forward_or_bwp(pp, p) ptr *pp; ptr p; {
|
|
seginfo *si;
|
|
/* adapted from relocate */
|
|
if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(p)) {
|
|
if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) {
|
|
*pp = FWDADDRESS(p);
|
|
} else {
|
|
*pp = Sbwp_object;
|
|
}
|
|
}
|
|
}
|
|
|
|
static void sweep_generation(tc, g) ptr tc; IGEN g; {
|
|
ptr *slp, *nlp; ptr *pp, p, *nl;
|
|
|
|
do {
|
|
change = 0;
|
|
sweep_space(space_impure, {
|
|
relocate_help(pp, p)
|
|
p = *(pp += 1);
|
|
relocate_help(pp, p)
|
|
pp += 1;
|
|
})
|
|
|
|
sweep_space(space_symbol, {
|
|
p = TYPE((ptr)pp, type_symbol);
|
|
sweep_symbol(p);
|
|
pp += size_symbol / sizeof(ptr);
|
|
})
|
|
|
|
sweep_space(space_port, {
|
|
p = TYPE((ptr)pp, type_typed_object);
|
|
sweep_port(p);
|
|
pp += size_port / sizeof(ptr);
|
|
})
|
|
|
|
sweep_space(space_weakpair, {
|
|
p = *(pp += 1);
|
|
relocate_help(pp, p)
|
|
pp += 1;
|
|
})
|
|
|
|
sweep_space(space_pure, {
|
|
relocate_help(pp, p)
|
|
p = *(pp += 1);
|
|
relocate_help(pp, p)
|
|
pp += 1;
|
|
})
|
|
|
|
sweep_space(space_continuation, {
|
|
p = TYPE((ptr)pp, type_closure);
|
|
sweep_continuation(p);
|
|
pp += size_continuation / sizeof(ptr);
|
|
})
|
|
|
|
sweep_space(space_pure_typed_object, {
|
|
p = TYPE((ptr)pp, type_typed_object);
|
|
pp = (ptr *)((uptr)pp + sweep_typed_object(p));
|
|
})
|
|
|
|
sweep_space(space_code, {
|
|
p = TYPE((ptr)pp, type_typed_object);
|
|
sweep_code_object(tc, p);
|
|
pp += size_code(CODELEN(p)) / sizeof(ptr);
|
|
})
|
|
|
|
sweep_space(space_impure_record, {
|
|
p = TYPE((ptr)pp, type_typed_object);
|
|
sweep_record(p);
|
|
pp = (ptr *)((iptr)pp +
|
|
size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p)))));
|
|
})
|
|
} while (change);
|
|
}
|
|
|
|
static iptr size_object(p) ptr p; {
|
|
ITYPE t; ptr tf;
|
|
|
|
if ((t = TYPEBITS(p)) == type_pair) {
|
|
return size_pair;
|
|
} else if (t == type_closure) {
|
|
ptr code = CLOSCODE(p);
|
|
if (CODETYPE(code) & (code_flag_continuation << code_flags_offset))
|
|
return size_continuation;
|
|
else
|
|
return size_closure(CLOSLEN(p));
|
|
} else if (t == type_symbol) {
|
|
return size_symbol;
|
|
} else if (t == type_flonum) {
|
|
return size_flonum;
|
|
/* typed objects */
|
|
} else if (tf = TYPEFIELD(p), TYPEP(tf, mask_fixnum, type_fixnum)) {
|
|
return size_vector(Svector_length(p));
|
|
} else if (TYPEP(tf, mask_string, type_string)) {
|
|
return size_string(Sstring_length(p));
|
|
} else if (TYPEP(tf, mask_bytevector, type_bytevector)) {
|
|
return size_bytevector(Sbytevector_length(p));
|
|
} else if (TYPEP(tf, mask_record, type_record)) {
|
|
return size_record_inst(UNFIX(RECORDDESCSIZE(tf)));
|
|
} else if (TYPEP(tf, mask_fxvector, type_fxvector)) {
|
|
return size_fxvector(Sfxvector_length(p));
|
|
} else if ((iptr)tf == type_box) {
|
|
return size_box;
|
|
} else if ((iptr)tf == type_ratnum) {
|
|
return size_ratnum;
|
|
} else if ((iptr)tf == type_exactnum) {
|
|
return size_exactnum;
|
|
} else if ((iptr)tf == type_inexactnum) {
|
|
return size_inexactnum;
|
|
} else if (TYPEP(tf, mask_bignum, type_bignum)) {
|
|
return size_bignum(BIGLEN(p));
|
|
} else if (TYPEP(tf, mask_port, type_port)) {
|
|
return size_port;
|
|
} else if (TYPEP(tf, mask_code, type_code)) {
|
|
return size_code(CODELEN(p));
|
|
} else if ((iptr)tf == type_thread) {
|
|
return size_thread;
|
|
} else if ((iptr)tf == type_rtd_counts) {
|
|
return size_rtd_counts;
|
|
} else {
|
|
S_error_abort("size_object(gc): illegal type");
|
|
return 0 /* not reached */;
|
|
}
|
|
}
|
|
|
|
static iptr sweep_typed_object(p) ptr p; {
|
|
ptr tf = TYPEFIELD(p);
|
|
|
|
if (TYPEP(tf, mask_record, type_record)) {
|
|
sweep_record(p);
|
|
return size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p))));
|
|
} else if (TYPEP(tf, mask_thread, type_thread)) {
|
|
sweep_thread(p);
|
|
return size_thread;
|
|
} else {
|
|
S_error_abort("sweep_typed_object(gc): unexpected type");
|
|
return 0 /* not reached */;
|
|
}
|
|
}
|
|
|
|
static void sweep_symbol(p) ptr p; {
|
|
ptr val, code;
|
|
|
|
val = SYMVAL(p);
|
|
relocate(&val);
|
|
INITSYMVAL(p) = val;
|
|
code = Sprocedurep(val) ? CLOSCODE(val) : SYMCODE(p);
|
|
relocate(&code);
|
|
INITSYMCODE(p,code);
|
|
relocate(&INITSYMPLIST(p))
|
|
relocate(&INITSYMSPLIST(p))
|
|
relocate(&INITSYMNAME(p))
|
|
relocate(&INITSYMHASH(p))
|
|
}
|
|
|
|
static void sweep_port(p) ptr p; {
|
|
relocate(&PORTHANDLER(p))
|
|
relocate(&PORTINFO(p))
|
|
relocate(&PORTNAME(p))
|
|
|
|
if (PORTTYPE(p) & PORT_FLAG_OUTPUT) {
|
|
iptr n = (iptr)PORTOLAST(p) - (iptr)PORTOBUF(p);
|
|
relocate(&PORTOBUF(p))
|
|
PORTOLAST(p) = (ptr)((iptr)PORTOBUF(p) + n);
|
|
}
|
|
|
|
if (PORTTYPE(p) & PORT_FLAG_INPUT) {
|
|
iptr n = (iptr)PORTILAST(p) - (iptr)PORTIBUF(p);
|
|
relocate(&PORTIBUF(p))
|
|
PORTILAST(p) = (ptr)((iptr)PORTIBUF(p) + n);
|
|
}
|
|
}
|
|
|
|
static void sweep_thread(p) ptr p; {
|
|
ptr tc = (ptr)THREADTC(p);
|
|
INT i;
|
|
|
|
if (tc != (ptr)0) {
|
|
ptr old_stack = SCHEMESTACK(tc);
|
|
if (OLDSPACE(old_stack)) {
|
|
iptr clength = (uptr)SFP(tc) - (uptr)old_stack;
|
|
/* include SFP[0], which contains the return address */
|
|
SCHEMESTACK(tc) = copy_stack(old_stack, &SCHEMESTACKSIZE(tc), clength + sizeof(ptr));
|
|
SFP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + clength);
|
|
ESP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + SCHEMESTACKSIZE(tc) - stack_slop);
|
|
}
|
|
STACKCACHE(tc) = Snil;
|
|
relocate(&CCHAIN(tc))
|
|
/* U32 RANDOMSEED(tc) */
|
|
/* I32 ACTIVE(tc) */
|
|
relocate(&STACKLINK(tc))
|
|
/* iptr SCHEMESTACKSIZE */
|
|
relocate(&WINDERS(tc))
|
|
relocate_return_addr(&FRAME(tc,0))
|
|
sweep_stack((uptr)SCHEMESTACK(tc), (uptr)SFP(tc), (uptr)FRAME(tc,0));
|
|
relocate(&U(tc))
|
|
relocate(&V(tc))
|
|
relocate(&W(tc))
|
|
relocate(&X(tc))
|
|
relocate(&Y(tc))
|
|
/* immediate SOMETHINGPENDING(tc) */
|
|
/* immediate TIMERTICKS */
|
|
/* immediate DISABLE_COUNT */
|
|
/* immediate SIGNALINTERRUPTPENDING */
|
|
/* immediate KEYBOARDINTERRUPTPENDING */
|
|
relocate(&THREADNO(tc))
|
|
relocate(&CURRENTINPUT(tc))
|
|
relocate(&CURRENTOUTPUT(tc))
|
|
relocate(&CURRENTERROR(tc))
|
|
/* immediate BLOCKCOUNTER */
|
|
relocate(&SFD(tc))
|
|
relocate(&TARGETMACHINE(tc))
|
|
relocate(&FXLENGTHBV(tc))
|
|
relocate(&FXFIRSTBITSETBV(tc))
|
|
/* immediate METALEVEL */
|
|
relocate(&COMPILEPROFILE(tc))
|
|
/* immediate GENERATEINSPECTORINFORMATION */
|
|
/* immediate GENERATEPROFILEFORMS */
|
|
/* immediate OPTIMIZELEVEL */
|
|
relocate(&PARAMETERS(tc))
|
|
/* U64 INSTRCOUNTER(tc) */
|
|
/* U64 ALLOCCOUNTER(tc) */
|
|
for (i = 0 ; i < virtual_register_count ; i += 1) {
|
|
relocate(&VIRTREG(tc, i));
|
|
}
|
|
}
|
|
}
|
|
|
|
static void sweep_continuation(p) ptr p; {
|
|
relocate(&CONTWINDERS(p))
|
|
|
|
/* bug out for shot 1-shot continuations */
|
|
if (CONTLENGTH(p) == scaled_shot_1_shot_flag) return;
|
|
|
|
if (OLDSPACE(CONTSTACK(p)))
|
|
CONTSTACK(p) = copy_stack(CONTSTACK(p), &CONTLENGTH(p), CONTCLENGTH(p));
|
|
|
|
relocate(&CONTLINK(p))
|
|
relocate_return_addr(&CONTRET(p))
|
|
|
|
/* use CLENGTH to avoid sweeping unoccupied portion of one-shots */
|
|
sweep_stack((uptr)CONTSTACK(p), (uptr)CONTSTACK(p) + CONTCLENGTH(p), (uptr)CONTRET(p));
|
|
}
|
|
|
|
/* assumes stack has already been copied to newspace */
|
|
static void sweep_stack(base, fp, ret) uptr base, fp, ret; {
|
|
ptr *pp; iptr oldret;
|
|
ptr num;
|
|
|
|
while (fp != base) {
|
|
if (fp < base)
|
|
S_error_abort("sweep_stack(gc): malformed stack");
|
|
fp = fp - ENTRYFRAMESIZE(ret);
|
|
pp = (ptr *)fp;
|
|
|
|
oldret = ret;
|
|
ret = (iptr)(*pp);
|
|
relocate_return_addr(pp)
|
|
|
|
num = ENTRYLIVEMASK(oldret);
|
|
if (Sfixnump(num)) {
|
|
uptr mask = UNFIX(num);
|
|
while (mask != 0) {
|
|
pp += 1;
|
|
if (mask & 0x0001) relocate(pp)
|
|
mask >>= 1;
|
|
}
|
|
} else {
|
|
iptr index;
|
|
|
|
relocate(&ENTRYLIVEMASK(oldret))
|
|
num = ENTRYLIVEMASK(oldret);
|
|
index = BIGLEN(num);
|
|
while (index-- != 0) {
|
|
INT bits = bigit_bits;
|
|
bigit mask = BIGIT(num,index);
|
|
while (bits-- > 0) {
|
|
pp += 1;
|
|
if (mask & 1) relocate(pp)
|
|
mask >>= 1;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
static void sweep_record(x) ptr x; {
|
|
ptr *pp; ptr num; ptr rtd;
|
|
|
|
/* record-type descriptor was forwarded in copy */
|
|
rtd = RECORDINSTTYPE(x);
|
|
num = RECORDDESCPM(rtd);
|
|
pp = &RECORDINSTIT(x,0);
|
|
|
|
/* sweep cells for which bit in pm is set; quit when pm == 0. */
|
|
if (Sfixnump(num)) {
|
|
/* ignore bit for already forwarded rtd */
|
|
uptr mask = (uptr)UNFIX(num) >> 1;
|
|
if (mask == (uptr)-1 >> 1) {
|
|
ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1;
|
|
while (pp < ppend) {
|
|
relocate(pp)
|
|
pp += 1;
|
|
}
|
|
} else {
|
|
while (mask != 0) {
|
|
if (mask & 1) relocate(pp)
|
|
mask >>= 1;
|
|
pp += 1;
|
|
}
|
|
}
|
|
} else {
|
|
iptr index; bigit mask; INT bits;
|
|
|
|
/* bignum pointer mask may have been forwarded */
|
|
relocate(&RECORDDESCPM(rtd))
|
|
num = RECORDDESCPM(rtd);
|
|
index = BIGLEN(num) - 1;
|
|
/* ignore bit for already forwarded rtd */
|
|
mask = BIGIT(num,index) >> 1;
|
|
bits = bigit_bits - 1;
|
|
for (;;) {
|
|
do {
|
|
if (mask & 1) relocate(pp)
|
|
mask >>= 1;
|
|
pp += 1;
|
|
} while (--bits > 0);
|
|
if (index-- == 0) break;
|
|
mask = BIGIT(num,index);
|
|
bits = bigit_bits;
|
|
}
|
|
}
|
|
}
|
|
|
|
static IGEN sweep_dirty_record(x) ptr x; {
|
|
ptr *pp; ptr num; ptr rtd; IGEN tg, youngest;
|
|
|
|
tg = target_generation;
|
|
youngest = 0xff;
|
|
|
|
/* warning: assuming rtd is immutable */
|
|
rtd = RECORDINSTTYPE(x);
|
|
|
|
/* warning: assuming MPM field is immutable */
|
|
num = RECORDDESCMPM(rtd);
|
|
pp = &RECORDINSTIT(x,0);
|
|
|
|
/* sweep cells for which bit in mpm is set
|
|
include rtd in case it's mutable */
|
|
if (Sfixnump(num)) {
|
|
/* ignore bit for assumed immutable rtd */
|
|
uptr mask = (uptr)UNFIX(num) >> 1;
|
|
while (mask != 0) {
|
|
if (mask & 1) relocate_dirty(pp,tg,youngest)
|
|
mask >>= 1;
|
|
pp += 1;
|
|
}
|
|
} else {
|
|
iptr index; bigit mask; INT bits;
|
|
|
|
index = BIGLEN(num) - 1;
|
|
/* ignore bit for assumed immutable rtd */
|
|
mask = BIGIT(num,index) >> 1;
|
|
bits = bigit_bits - 1;
|
|
for (;;) {
|
|
do {
|
|
if (mask & 1) relocate_dirty(pp,tg,youngest)
|
|
mask >>= 1;
|
|
pp += 1;
|
|
} while (--bits > 0);
|
|
if (index-- == 0) break;
|
|
mask = BIGIT(num,index);
|
|
bits = bigit_bits;
|
|
}
|
|
}
|
|
|
|
return youngest;
|
|
}
|
|
|
|
static void sweep_code_object(tc, co) ptr tc, co; {
|
|
ptr t, oldco; iptr a, m, n;
|
|
|
|
#ifdef DEBUG
|
|
if ((CODETYPE(co) & mask_code) != type_code) {
|
|
(void)printf("unexpected type %x sweeping code object %p\n", CODETYPE(co), co);
|
|
(void)fflush(stdout);
|
|
}
|
|
#endif
|
|
|
|
relocate(&CODENAME(co))
|
|
relocate(&CODEINFO(co))
|
|
relocate(&CODEPINFOS(co))
|
|
|
|
t = CODERELOC(co);
|
|
m = RELOCSIZE(t);
|
|
oldco = RELOCCODE(t);
|
|
a = 0;
|
|
n = 0;
|
|
while (n < m) {
|
|
uptr entry, item_off, code_off; ptr obj;
|
|
entry = RELOCIT(t, n); n += 1;
|
|
if (RELOC_EXTENDED_FORMAT(entry)) {
|
|
item_off = RELOCIT(t, n); n += 1;
|
|
code_off = RELOCIT(t, n); n += 1;
|
|
} else {
|
|
item_off = RELOC_ITEM_OFFSET(entry);
|
|
code_off = RELOC_CODE_OFFSET(entry);
|
|
}
|
|
a += code_off;
|
|
obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off);
|
|
relocate(&obj)
|
|
S_set_code_obj("gc", RELOC_TYPE(entry), co, a, obj, item_off);
|
|
}
|
|
|
|
if (target_generation == static_generation && !S_G.retain_static_relocation) {
|
|
CODERELOC(co) = (ptr)0;
|
|
} else {
|
|
/* Don't copy non-oldspace relocation tables, since we may be
|
|
sweeping a locked code object that is older than target_generation
|
|
Doing so would be a waste of work anyway. */
|
|
if (OLDSPACE(t)) {
|
|
ptr oldt = t;
|
|
n = size_reloc_table(RELOCSIZE(oldt));
|
|
#ifdef ENABLE_OBJECT_COUNTS
|
|
S_G.countof[target_generation][countof_relocation_table] += 1;
|
|
S_G.bytesof[target_generation][countof_relocation_table] += n;
|
|
#endif /* ENABLE_OBJECT_COUNTS */
|
|
find_room(space_data, target_generation, typemod, n, t);
|
|
copy_ptrs(typemod, t, oldt, n);
|
|
}
|
|
RELOCCODE(t) = co;
|
|
CODERELOC(co) = t;
|
|
}
|
|
|
|
S_record_code_mod(tc, (uptr)&CODEIT(co,0), (uptr)CODELEN(co));
|
|
}
|
|
|
|
typedef struct _weakseginfo {
|
|
seginfo *si;
|
|
IGEN youngest[cards_per_segment];
|
|
struct _weakseginfo *next;
|
|
} weakseginfo;
|
|
|
|
static weakseginfo *weaksegments_to_resweep;
|
|
|
|
static void record_dirty_segment(IGEN from_g, IGEN to_g, seginfo *si) {
|
|
if (si->min_dirty_byte != 0xff) {
|
|
S_error_abort("record_dirty(gc): unexpected mutation while sweeping");
|
|
}
|
|
|
|
if (to_g < from_g) {
|
|
seginfo *oldfirst = DirtySegments(from_g, to_g);
|
|
DirtySegments(from_g, to_g) = si;
|
|
si->dirty_prev = &DirtySegments(from_g, to_g);
|
|
si->dirty_next = oldfirst;
|
|
if (oldfirst != NULL) oldfirst->dirty_prev = &si->dirty_next;
|
|
si->min_dirty_byte = to_g;
|
|
}
|
|
}
|
|
|
|
static void sweep_dirty(void) {
|
|
IGEN tg, mcg, youngest, min_youngest, pg;
|
|
ptr *pp, *ppend, *nl;
|
|
uptr seg, d;
|
|
ISPC s;
|
|
IGEN from_g, to_g;
|
|
seginfo *dirty_si, *nextsi;
|
|
|
|
tg = target_generation;
|
|
mcg = max_copied_generation;
|
|
weaksegments_to_resweep = NULL;
|
|
|
|
/* clear dirty segment lists for copied generations */
|
|
for (from_g = 1; from_g <= mcg; from_g += 1) {
|
|
for (to_g = 0; to_g < from_g; to_g += 1) {
|
|
DirtySegments(from_g, to_g) = NULL;
|
|
}
|
|
}
|
|
|
|
/* NB: could have problems if a card is moved from some current or to-be-swept (from_g, to_g) to some previously
|
|
swept list due to a dirty_set while we sweep. believe this can't happen as of 6/14/2013. if it can, it
|
|
might be sufficient to process the lists in reverse order. */
|
|
for (from_g = mcg + 1; from_g <= static_generation; INCRGEN(from_g)) {
|
|
for (to_g = 0; to_g <= mcg; to_g += 1) {
|
|
for (dirty_si = DirtySegments(from_g, to_g), DirtySegments(from_g, to_g) = NULL; dirty_si != NULL; dirty_si = nextsi) {
|
|
nextsi = dirty_si->dirty_next;
|
|
seg = dirty_si->number;
|
|
s = dirty_si->space;
|
|
|
|
if (s & space_locked) continue;
|
|
|
|
/* reset min dirty byte so we can detect if byte is set while card is swept */
|
|
dirty_si->min_dirty_byte = 0xff;
|
|
|
|
min_youngest = 0xff;
|
|
nl = from_g == tg ? (ptr *)orig_next_loc[s] : (ptr *)S_G.next_loc[s][from_g];
|
|
ppend = build_ptr(seg, 0);
|
|
|
|
if (s == space_weakpair) {
|
|
weakseginfo *next = weaksegments_to_resweep;
|
|
find_room(space_data, 0, typemod, sizeof(weakseginfo), weaksegments_to_resweep);
|
|
weaksegments_to_resweep->si = dirty_si;
|
|
weaksegments_to_resweep->next = next;
|
|
}
|
|
|
|
d = 0;
|
|
while (d < cards_per_segment) {
|
|
uptr dend = d + sizeof(iptr);
|
|
iptr *dp = (iptr *)(dirty_si->dirty_bytes + d);
|
|
/* check sizeof(iptr) bytes at a time for 0xff */
|
|
if (*dp == -1) {
|
|
pp = ppend;
|
|
ppend += bytes_per_card;
|
|
if (pp <= nl && nl < ppend) ppend = nl;
|
|
d = dend;
|
|
} else {
|
|
while (d < dend) {
|
|
pp = ppend;
|
|
ppend += bytes_per_card / sizeof(ptr);
|
|
if (pp <= nl && nl < ppend) ppend = nl;
|
|
|
|
if (dirty_si->dirty_bytes[d] <= mcg) {
|
|
/* assume we won't find any wrong-way pointers */
|
|
youngest = 0xff;
|
|
|
|
if (s == space_impure) {
|
|
while (pp < ppend && *pp != forward_marker) {
|
|
/* handle two pointers at a time */
|
|
relocate_dirty(pp,tg,youngest)
|
|
pp += 1;
|
|
relocate_dirty(pp,tg,youngest)
|
|
pp += 1;
|
|
}
|
|
} else if (s == space_symbol) {
|
|
/* old symbols cannot overlap segment boundaries
|
|
since any object that spans multiple
|
|
generations begins at the start of a segment,
|
|
and symbols are much smaller (we assume)
|
|
than the segment size. */
|
|
pp = (ptr *)build_ptr(seg,0) +
|
|
((pp - (ptr *)build_ptr(seg,0)) /
|
|
(size_symbol / sizeof(ptr))) *
|
|
(size_symbol / sizeof(ptr));
|
|
|
|
while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a symbol. no harm. */
|
|
ptr p, val, code;
|
|
|
|
p = TYPE((ptr)pp, type_symbol);
|
|
|
|
val = SYMVAL(p);
|
|
relocate_dirty(&val,tg,youngest)
|
|
INITSYMVAL(p) = val;
|
|
code = Sprocedurep(val) ? CLOSCODE(val) : SYMCODE(p);
|
|
relocate_dirty(&code,tg,youngest)
|
|
INITSYMCODE(p,code);
|
|
relocate_dirty(&INITSYMPLIST(p),tg,youngest)
|
|
relocate_dirty(&INITSYMSPLIST(p),tg,youngest)
|
|
relocate_dirty(&INITSYMNAME(p),tg,youngest)
|
|
relocate_dirty(&INITSYMHASH(p),tg,youngest)
|
|
|
|
pp += size_symbol / sizeof(ptr);
|
|
}
|
|
} else if (s == space_port) {
|
|
/* old ports cannot overlap segment boundaries
|
|
since any object that spans multiple
|
|
generations begins at the start of a segment,
|
|
and ports are much smaller (we assume)
|
|
than the segment size. */
|
|
pp = (ptr *)build_ptr(seg,0) +
|
|
((pp - (ptr *)build_ptr(seg,0)) /
|
|
(size_port / sizeof(ptr))) *
|
|
(size_port / sizeof(ptr));
|
|
|
|
while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a port. no harm. */
|
|
ptr p = TYPE((ptr)pp, type_typed_object);
|
|
|
|
relocate_dirty(&PORTHANDLER(p),tg,youngest)
|
|
relocate_dirty(&PORTINFO(p),tg,youngest)
|
|
relocate_dirty(&PORTNAME(p),tg,youngest)
|
|
|
|
if (PORTTYPE(p) & PORT_FLAG_OUTPUT) {
|
|
iptr n = (iptr)PORTOLAST(p) - (iptr)PORTOBUF(p);
|
|
relocate_dirty(&PORTOBUF(p),tg,youngest)
|
|
PORTOLAST(p) = (ptr)((iptr)PORTOBUF(p) + n);
|
|
}
|
|
|
|
if (PORTTYPE(p) & PORT_FLAG_INPUT) {
|
|
iptr n = (iptr)PORTILAST(p) - (iptr)PORTIBUF(p);
|
|
relocate_dirty(&PORTIBUF(p),tg,youngest)
|
|
PORTILAST(p) = (ptr)((iptr)PORTIBUF(p) + n);
|
|
}
|
|
|
|
pp += size_port / sizeof(ptr);
|
|
}
|
|
} else if (s == space_impure_record) { /* abandon hope all ye who enter here */
|
|
uptr j; ptr p, pnext; seginfo *si;
|
|
|
|
/* synchronize on first record that overlaps the dirty
|
|
area, then relocate any mutable pointers in that
|
|
record and those that follow within the dirty area. */
|
|
|
|
/* find first segment of group of like segments */
|
|
j = seg - 1;
|
|
while ((si = MaybeSegInfo(j)) != NULL &&
|
|
si->space == s &&
|
|
si->generation == from_g)
|
|
j -= 1;
|
|
j += 1;
|
|
|
|
/* now find first record in segment seg */
|
|
/* we count on following fact: if an object spans two
|
|
or more segments, then he starts at the beginning
|
|
of a segment */
|
|
for (;;) {
|
|
p = TYPE(build_ptr(j,0),type_typed_object);
|
|
pnext = (ptr)((iptr)p +
|
|
size_record_inst(UNFIX(RECORDDESCSIZE(
|
|
RECORDINSTTYPE(p)))));
|
|
if (ptr_get_segment(pnext) >= seg) break;
|
|
j = ptr_get_segment(pnext) + 1;
|
|
}
|
|
|
|
/* now find first within dirty area */
|
|
while ((ptr *)UNTYPE(pnext, type_typed_object) <= pp) {
|
|
p = pnext;
|
|
pnext = (ptr)((iptr)p +
|
|
size_record_inst(UNFIX(RECORDDESCSIZE(
|
|
RECORDINSTTYPE(p)))));
|
|
}
|
|
|
|
/* now sweep */
|
|
while ((ptr *)UNTYPE(p, type_typed_object) < ppend) {
|
|
/* quit on end of segment */
|
|
if (FWDMARKER(p) == forward_marker) break;
|
|
|
|
pg = sweep_dirty_record(p);
|
|
if (pg < youngest) youngest = pg;
|
|
p = (ptr)((iptr)p +
|
|
size_record_inst(UNFIX(RECORDDESCSIZE(
|
|
RECORDINSTTYPE(p)))));
|
|
}
|
|
} else if (s == space_weakpair) {
|
|
while (pp < ppend && *pp != forward_marker) {
|
|
/* skip car field and handle cdr field */
|
|
pp += 1;
|
|
relocate_dirty(pp, tg, youngest)
|
|
pp += 1;
|
|
}
|
|
} else {
|
|
S_error_abort("sweep_dirty(gc): unexpected space");
|
|
}
|
|
|
|
if (s == space_weakpair) {
|
|
weaksegments_to_resweep->youngest[d] = youngest;
|
|
} else {
|
|
dirty_si->dirty_bytes[d] = youngest < from_g ? youngest : 0xff;
|
|
}
|
|
if (youngest < min_youngest) min_youngest = youngest;
|
|
} else {
|
|
if (dirty_si->dirty_bytes[d] < min_youngest) min_youngest = dirty_si->dirty_bytes[d];
|
|
}
|
|
d += 1;
|
|
}
|
|
}
|
|
}
|
|
if (s != space_weakpair) {
|
|
record_dirty_segment(from_g, min_youngest, dirty_si);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
static void resweep_dirty_weak_pairs() {
|
|
weakseginfo *ls;
|
|
ptr *pp, *ppend, *nl, p;
|
|
IGEN from_g, min_youngest, youngest, tg, mcg, pg;
|
|
uptr d;
|
|
|
|
tg = target_generation;
|
|
mcg = max_copied_generation;
|
|
|
|
for (ls = weaksegments_to_resweep; ls != NULL; ls = ls->next) {
|
|
seginfo *dirty_si = ls->si;
|
|
from_g = dirty_si->generation;
|
|
nl = from_g == tg ? (ptr *)orig_next_loc[space_weakpair] : (ptr *)S_G.next_loc[space_weakpair][from_g];
|
|
ppend = build_ptr(dirty_si->number, 0);
|
|
min_youngest = 0xff;
|
|
d = 0;
|
|
while (d < cards_per_segment) {
|
|
uptr dend = d + sizeof(iptr);
|
|
iptr *dp = (iptr *)(dirty_si->dirty_bytes + d);
|
|
/* check sizeof(iptr) bytes at a time for 0xff */
|
|
if (*dp == -1) {
|
|
d = dend;
|
|
ppend += bytes_per_card;
|
|
} else {
|
|
while (d < dend) {
|
|
pp = ppend;
|
|
ppend += bytes_per_card / sizeof(ptr);
|
|
if (pp <= nl && nl < ppend) ppend = nl;
|
|
if (dirty_si->dirty_bytes[d] <= mcg) {
|
|
youngest = ls->youngest[d];
|
|
while (pp < ppend) {
|
|
p = *pp;
|
|
seginfo *si;
|
|
|
|
/* handle car field */
|
|
if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) {
|
|
if (si->space & space_old) {
|
|
if (locked(p)) {
|
|
youngest = tg;
|
|
} else if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) {
|
|
*pp = FWDADDRESS(p);
|
|
youngest = tg;
|
|
} else {
|
|
*pp = Sbwp_object;
|
|
}
|
|
} else {
|
|
if (youngest != tg && (pg = si->generation) < youngest)
|
|
youngest = pg;
|
|
}
|
|
}
|
|
|
|
/* skip cdr field */
|
|
pp += 2;
|
|
}
|
|
|
|
dirty_si->dirty_bytes[d] = youngest < from_g ? youngest : 0xff;
|
|
if (youngest < min_youngest) min_youngest = youngest;
|
|
} else {
|
|
if (dirty_si->dirty_bytes[d] < min_youngest) min_youngest = dirty_si->dirty_bytes[d];
|
|
}
|
|
d += 1;
|
|
}
|
|
}
|
|
}
|
|
record_dirty_segment(from_g, min_youngest, dirty_si);
|
|
}
|
|
}
|