/* 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 #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; /* allocte 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); } }