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

369.12

Browse Source 
svn: r6115
This commit is contained in:
Matthew Flatt 2007-05-01 23:46:51 +00:00
parent 25789f09d8
commit 0cba826ae5
16 changed files with 1884 additions and 1590 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/tests/mzscheme/will.ss
View File

@ -55,4 +55,67 @@
(arity-test will-execute 1 1)
(arity-test will-try-execute 1 1)
;; ----------------------------------------
;; Test custodian boxes
(let ([c (make-custodian)]
[we (make-will-executor)]
[removed null])
(let ([mk-finalized (lambda (n)
(let ([l (list n)])
(will-register we l (lambda (v)
(set! removed (cons (car v) removed))))
(make-custodian-box c l)))]
[gc (lambda ()
(collect-garbage)
(collect-garbage)
(let loop ()
(when (will-try-execute we)
(loop)))
(collect-garbage)
(collect-garbage))]
[b1 (make-custodian-box c 12)])
(let ([saved (map mk-finalized '(a b c d e f g h i))])
(let loop ([m 2])
(unless (zero? m)
(set! removed null)
(let loop ([n 100])
(unless (zero? n)
(mk-finalized n)
(loop (sub1 n))))
(gc)
;; finalize at least half?
(test #t > (length removed) 50)
(test #f ormap symbol? removed)
(test 12 custodian-box-value b1)
(loop (sub1 m))))
(test #t andmap (lambda (x) (and (pair? x) (symbol? (car x))))
(map custodian-box-value saved))
(set! removed null)
(custodian-shutdown-all c)
(test #f custodian-box-value b1)
(test #f ormap values (map custodian-box-value saved))
(gc)
(test #t <= 5 (apply + (map (lambda (v) (if (symbol? v) 1 0)) removed))))))
(when (custodian-memory-accounting-available?)
;; Check custodian boxes for accounting
(let* ([c (map (lambda (n) (make-custodian))
'(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))]
[b (map (lambda (c)
(make-custodian-box c (make-bytes 100000)))
c)]
[t (map (lambda (c)
;; Each thread can reach all boxes:
(parameterize ([current-custodian c])
(thread (lambda () (sync (make-semaphore)) b))))
c)])
;; Each custodian must be charged at least 100000 bytes:
(collect-garbage)
(test #t andmap (lambda (c)
((current-memory-use c) . >= . 100000))
c)))
;; ----------------------------------------
(report-errs)

3
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,6 @@
Version 369.12
Add custodian boxes
Version 369.11
Added reset?, start-, and end-index arguments to get-output-bytes
Added custodian-memory-accounting-available?

2
src/mzscheme/gc2/compact.c
View File

@ -431,7 +431,7 @@ void GC_set_stack_base(void *base)
stack_base = (unsigned long)base;
}
void GC_init_type_tags(int count, int pair, int weakbox, int ephemeron, int weakarray)
void GC_init_type_tags(int count, int pair, int weakbox, int ephemeron, int weakarray, int custbox)
{
pair_tag = pair;
weak_box_tag = weakbox;

7
src/mzscheme/gc2/gc2.h
View File

@ -64,12 +64,13 @@ GC2_EXTERN void GC_add_roots(void *start, void *end);
Called by MzScheme to install roots. The memory between
`start' (inclusive) and `end' (exclusive) contains pointers. */
GC2_EXTERN void GC_init_type_tags(int count, int pair, int weakbox, int ephemeron, int weakarray);
GC2_EXTERN void GC_init_type_tags(int count, int pair, int weakbox,
int ephemeron, int weakarray, int custbox);
/*
Called by MzScheme to indicate the number of different type tags it
uses, starting from 0. `count' is always less than 256. The weakbox
argument is the value to be used for tagging weak box, and the
ephemeron is the value to tagging an ephemeron. (The GC has some
argument is the value to be used for tagging weak box, the
ephemeron is the value to tagging an ephemeron, etc. (The GC has some
freedom in the layout of a weak box or ephemeron, so it performs weak
box traversals itself, but MzScheme gets to choose the tag.) */

55
src/mzscheme/gc2/newgc.c
View File

@ -1184,9 +1184,11 @@ struct thread {
struct thread *next;
};
static Mark_Proc normal_thread_mark = NULL, normal_custodian_mark = NULL;
static Mark_Proc normal_thread_mark = NULL, normal_custodian_mark = NULL, normal_cust_box_mark = NULL;
static struct thread *threads = NULL;
static unsigned short cust_box_tag;
inline static void register_new_thread(void *t, void *c)
{
struct thread *work;
@ -1226,6 +1228,31 @@ inline static void mark_threads(int owner)
}
}
inline static void mark_cust_boxes(Scheme_Custodian *cur)
{
Scheme_Object *pr, *prev = NULL, *next;
GC_Weak_Box *wb;
/* cust boxes is a list of weak boxes to cust boxes */
pr = cur->cust_boxes;
while (pr) {
wb = (GC_Weak_Box *)SCHEME_CAR(pr);
next = SCHEME_CDR(pr);
if (wb->val) {
normal_cust_box_mark(wb->val);
prev = pr;
} else {
if (prev)
SCHEME_CDR(prev) = next;
else
cur->cust_boxes = next;
}
pr = next;
}
cur->cust_boxes = NULL;
}
inline static void clean_up_thread_list(void)
{
struct thread *work = threads, *prev = NULL;
@ -1555,6 +1582,10 @@ int BTC_custodian_mark(void *p)
return ((struct objhead *)(NUM(p) - WORD_SIZE))->size;
}
int BTC_cust_box_mark(void *p)
{
return ((struct objhead *)(NUM(p) - WORD_SIZE))->size;
}
inline static void mark_normal_obj(struct mpage *page, void *ptr)
{
@ -1657,11 +1688,13 @@ static void do_btc_accounting(void)
if(!normal_thread_mark) {
normal_thread_mark = mark_table[scheme_thread_type];
normal_custodian_mark = mark_table[scheme_custodian_type];
normal_cust_box_mark = mark_table[cust_box_tag];
}
mark_table[scheme_thread_type] = &BTC_thread_mark;
mark_table[scheme_custodian_type] = &BTC_custodian_mark;
mark_table[ephemeron_tag] = btc_mark_ephemeron;
mark_table[cust_box_tag] = BTC_cust_box_mark;
/* clear the memory use numbers out */
for(i = 1; i < owner_table_top; i++)
if(owner_table[i])
@ -1672,7 +1705,7 @@ static void do_btc_accounting(void)
cur = (Scheme_Custodian*)SCHEME_PTR1_VAL(box);
box = cur->global_next;
}
/* walk backwards for the order we want */
while(cur) {
int owner = custodian_to_owner_set(cur);
@ -1682,6 +1715,7 @@ static void do_btc_accounting(void)
owner, cur));
kill_propagation_loop = 0;
mark_threads(owner);
mark_cust_boxes(cur);
GCDEBUG((DEBUGOUTF, "Propagating accounting marks\n"));
propagate_accounting_marks();
@ -1691,6 +1725,7 @@ static void do_btc_accounting(void)
mark_table[scheme_thread_type] = normal_thread_mark;
mark_table[scheme_custodian_type] = normal_custodian_mark;
mark_table[ephemeron_tag] = mark_ephemeron;
mark_table[cust_box_tag] = normal_cust_box_mark;
in_unsafe_allocation_mode = 0;
doing_memory_accounting = 0;
old_btc_mark = new_btc_mark;
@ -1918,13 +1953,16 @@ void GC_write_barrier(void *p)
#include "sighand.c"
void GC_init_type_tags(int count, int pair, int weakbox, int ephemeron, int weakarray)
void GC_init_type_tags(int count, int pair, int weakbox, int ephemeron, int weakarray, int custbox)
{
static int initialized = 0;
weak_box_tag = weakbox;
ephemeron_tag = ephemeron;
weak_array_tag = weakarray;
# ifdef NEWGC_BTC_ACCOUNT
cust_box_tag = custbox;
# endif
if(!initialized) {
initialized = 1;
@ -2448,11 +2486,6 @@ static void prepare_pages_for_collection(void)
}
flush_protect_page_ranges(1);
}
/* we do this here because, well, why not? */
init_weak_boxes();
init_weak_arrays();
init_ephemerons();
}
static void mark_backpointers(void)
@ -2852,6 +2885,10 @@ static void garbage_collect(int force_full)
TIME_STEP("started");
prepare_pages_for_collection();
init_weak_boxes();
init_weak_arrays();
init_ephemerons();
/* at this point, the page map should only include pages that contain
collectable objects */

3012
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

39
src/mzscheme/src/mzmark.c
View File

@ -3676,6 +3676,8 @@ static int mark_custodian_val_MARK(void *p) {
gcMARK(m->global_next);
gcMARK(m->global_prev);
gcMARK(m->cust_boxes);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Custodian));
}
@ -3695,6 +3697,8 @@ static int mark_custodian_val_FIXUP(void *p) {
gcFIXUP(m->global_next);
gcFIXUP(m->global_prev);
gcFIXUP(m->cust_boxes);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Custodian));
}
@ -3703,6 +3707,41 @@ static int mark_custodian_val_FIXUP(void *p) {
#define mark_custodian_val_IS_CONST_SIZE 1
static int mark_custodian_box_val_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Custodian_Box));
}
static int mark_custodian_box_val_MARK(void *p) {
Scheme_Custodian_Box *b = (Scheme_Custodian_Box *)p;
int sd = ((Scheme_Custodian *)GC_resolve(b->cust))->shut_down;
gcMARK(b->cust);
if (!sd) {
gcMARK(b->v);
}
return
gcBYTES_TO_WORDS(sizeof(Scheme_Custodian_Box));
}
static int mark_custodian_box_val_FIXUP(void *p) {
Scheme_Custodian_Box *b = (Scheme_Custodian_Box *)p;
int sd = ((Scheme_Custodian *)GC_resolve(b->cust))->shut_down;
gcFIXUP(b->cust);
if (!sd) {
gcFIXUP(b->v);
}
return
gcBYTES_TO_WORDS(sizeof(Scheme_Custodian_Box));
}
#define mark_custodian_box_val_IS_ATOMIC 0
#define mark_custodian_box_val_IS_CONST_SIZE 1
static int mark_thread_hop_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Thread_Custodian_Hop));

16
src/mzscheme/src/mzmarksrc.c
View File

@ -1497,10 +1497,26 @@ mark_custodian_val {
gcMARK(m->global_next);
gcMARK(m->global_prev);
gcMARK(m->cust_boxes);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Custodian));
}
mark_custodian_box_val {
mark:
Scheme_Custodian_Box *b = (Scheme_Custodian_Box *)p;
int sd = ((Scheme_Custodian *)GC_resolve(b->cust))->shut_down;
gcMARK(b->cust);
if (!sd) {
gcMARK(b->v);
}
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Custodian_Box));
}
mark_thread_hop {
mark:
Scheme_Thread_Custodian_Hop *hop = (Scheme_Thread_Custodian_Hop *)p;

3
src/mzscheme/src/salloc.c
View File

@ -65,7 +65,8 @@ void scheme_set_stack_base(void *base, int no_auto_statics)
#ifdef MZ_PRECISE_GC
GC_init_type_tags(_scheme_last_type_,
scheme_pair_type, scheme_weak_box_type,
scheme_ephemeron_type, scheme_rt_weak_array);
scheme_ephemeron_type, scheme_rt_weak_array,
scheme_cust_box_type);
#endif
#if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC)
GC_set_stack_base(base);

2
src/mzscheme/src/schminc.h
View File

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 894
#define EXPECTED_PRIM_COUNT 896
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

8
src/mzscheme/src/schpriv.h
View File

@ -375,9 +375,16 @@ struct Scheme_Custodian {
#ifdef MZ_PRECISE_GC
int gc_owner_set;
Scheme_Object *cust_boxes;
#endif
};
typedef struct Scheme_Custodian_Box {
Scheme_Object so;
Scheme_Custodian *cust;
Scheme_Object *v;
} Scheme_Custodian_Box;
Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_Func f);
typedef struct Scheme_Security_Guard {
@ -887,6 +894,7 @@ Scheme_Object *scheme_unclose_case_lambda(Scheme_Object *expr, int jit);
Scheme_Object *scheme_native_stack_trace(void);
void scheme_clean_native_symtab(void);
void scheme_clean_cust_box_list(void);
/*========================================================================*/
/* control flow */

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 369
#define MZSCHEME_VERSION_MINOR 11
#define MZSCHEME_VERSION_MINOR 12
#define MZSCHEME_VERSION "369.11" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "369.12" _MZ_SPECIAL_TAG

137
src/mzscheme/src/stypes.h
View File

@ -158,78 +158,79 @@ enum {
scheme_prompt_tag_type, /* 140 */
scheme_expanded_syntax_type, /* 141 */
scheme_delay_syntax_type, /* 142 */
scheme_cust_box_type, /* 143 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 143 */
_scheme_last_normal_type_, /* 144 */
scheme_rt_weak_array, /* 144 */
scheme_rt_weak_array, /* 145 */
scheme_rt_comp_env, /* 145 */
scheme_rt_constant_binding, /* 146 */
scheme_rt_resolve_info, /* 147 */
scheme_rt_optimize_info, /* 148 */
scheme_rt_compile_info, /* 149 */
scheme_rt_cont_mark, /* 150 */
scheme_rt_saved_stack, /* 151 */
scheme_rt_reply_item, /* 152 */
scheme_rt_closure_info, /* 153 */
scheme_rt_overflow, /* 154 */
scheme_rt_overflow_jmp, /* 155 */
scheme_rt_meta_cont, /* 156 */
scheme_rt_dyn_wind_cell, /* 157 */
scheme_rt_dyn_wind_info, /* 158 */
scheme_rt_dyn_wind, /* 159 */
scheme_rt_dup_check, /* 160 */
scheme_rt_thread_memory, /* 161 */
scheme_rt_input_file, /* 162 */
scheme_rt_input_fd, /* 163 */
scheme_rt_oskit_console_input, /* 164 */
scheme_rt_tested_input_file, /* 165 */
scheme_rt_tested_output_file, /* 166 */
scheme_rt_indexed_string, /* 167 */
scheme_rt_output_file, /* 168 */
scheme_rt_load_handler_data, /* 169 */
scheme_rt_pipe, /* 170 */
scheme_rt_beos_process, /* 171 */
scheme_rt_system_child, /* 172 */
scheme_rt_tcp, /* 173 */
scheme_rt_write_data, /* 174 */
scheme_rt_tcp_select_info, /* 175 */
scheme_rt_namespace_option, /* 176 */
scheme_rt_param_data, /* 177 */
scheme_rt_will, /* 178 */
scheme_rt_will_registration, /* 179 */
scheme_rt_struct_proc_info, /* 180 */
scheme_rt_linker_name, /* 181 */
scheme_rt_param_map, /* 182 */
scheme_rt_finalization, /* 183 */
scheme_rt_finalizations, /* 184 */
scheme_rt_cpp_object, /* 185 */
scheme_rt_cpp_array_object, /* 186 */
scheme_rt_stack_object, /* 187 */
scheme_rt_preallocated_object, /* 188 */
scheme_thread_hop_type, /* 189 */
scheme_rt_srcloc, /* 190 */
scheme_rt_evt, /* 191 */
scheme_rt_syncing, /* 192 */
scheme_rt_comp_prefix, /* 193 */
scheme_rt_user_input, /* 194 */
scheme_rt_user_output, /* 195 */
scheme_rt_compact_port, /* 196 */
scheme_rt_read_special_dw, /* 197 */
scheme_rt_regwork, /* 198 */
scheme_rt_buf_holder, /* 199 */
scheme_rt_parameterization, /* 200 */
scheme_rt_print_params, /* 201 */
scheme_rt_read_params, /* 202 */
scheme_rt_native_code, /* 203 */
scheme_rt_native_code_plus_case, /* 204 */
scheme_rt_jitter_data, /* 205 */
scheme_rt_module_exports, /* 206 */
scheme_rt_delay_load_info, /* 207 */
scheme_rt_marshal_info, /* 208 */
scheme_rt_unmarshal_info, /* 209 */
scheme_rt_runstack, /* 210 */
scheme_rt_comp_env, /* 146 */
scheme_rt_constant_binding, /* 147 */
scheme_rt_resolve_info, /* 148 */
scheme_rt_optimize_info, /* 149 */
scheme_rt_compile_info, /* 150 */
scheme_rt_cont_mark, /* 151 */
scheme_rt_saved_stack, /* 152 */
scheme_rt_reply_item, /* 153 */
scheme_rt_closure_info, /* 154 */
scheme_rt_overflow, /* 155 */
scheme_rt_overflow_jmp, /* 156 */
scheme_rt_meta_cont, /* 157 */
scheme_rt_dyn_wind_cell, /* 158 */
scheme_rt_dyn_wind_info, /* 159 */
scheme_rt_dyn_wind, /* 160 */
scheme_rt_dup_check, /* 161 */
scheme_rt_thread_memory, /* 162 */
scheme_rt_input_file, /* 163 */
scheme_rt_input_fd, /* 164 */
scheme_rt_oskit_console_input, /* 165 */
scheme_rt_tested_input_file, /* 166 */
scheme_rt_tested_output_file, /* 167 */
scheme_rt_indexed_string, /* 168 */
scheme_rt_output_file, /* 169 */
scheme_rt_load_handler_data, /* 170 */
scheme_rt_pipe, /* 171 */
scheme_rt_beos_process, /* 172 */
scheme_rt_system_child, /* 173 */
scheme_rt_tcp, /* 174 */
scheme_rt_write_data, /* 175 */
scheme_rt_tcp_select_info, /* 176 */
scheme_rt_namespace_option, /* 177 */
scheme_rt_param_data, /* 178 */
scheme_rt_will, /* 179 */
scheme_rt_will_registration, /* 180 */
scheme_rt_struct_proc_info, /* 181 */
scheme_rt_linker_name, /* 182 */
scheme_rt_param_map, /* 183 */
scheme_rt_finalization, /* 184 */
scheme_rt_finalizations, /* 185 */
scheme_rt_cpp_object, /* 186 */
scheme_rt_cpp_array_object, /* 187 */
scheme_rt_stack_object, /* 188 */
scheme_rt_preallocated_object, /* 189 */
scheme_thread_hop_type, /* 190 */
scheme_rt_srcloc, /* 191 */
scheme_rt_evt, /* 192 */
scheme_rt_syncing, /* 193 */
scheme_rt_comp_prefix, /* 194 */
scheme_rt_user_input, /* 195 */
scheme_rt_user_output, /* 196 */
scheme_rt_compact_port, /* 197 */
scheme_rt_read_special_dw, /* 198 */
scheme_rt_regwork, /* 199 */
scheme_rt_buf_holder, /* 200 */
scheme_rt_parameterization, /* 201 */
scheme_rt_print_params, /* 202 */
scheme_rt_read_params, /* 203 */
scheme_rt_native_code, /* 204 */
scheme_rt_native_code_plus_case, /* 205 */
scheme_rt_jitter_data, /* 206 */
scheme_rt_module_exports, /* 207 */
scheme_rt_delay_load_info, /* 208 */
scheme_rt_marshal_info, /* 209 */
scheme_rt_unmarshal_info, /* 210 */
scheme_rt_runstack, /* 211 */
#endif
_scheme_last_type_

3
src/mzscheme/src/symbol.c
View File

@ -240,6 +240,9 @@ static void clean_symbol_table(void)
# ifdef MZ_USE_JIT
scheme_clean_native_symtab();
# endif
# ifndef MZ_PRECISE_GC
scheme_clean_cust_box_list();
# endif
}
#endif

119
src/mzscheme/src/thread.c
View File

@ -177,6 +177,14 @@ static Scheme_Custodian *main_custodian;
static Scheme_Custodian *last_custodian;
static Scheme_Hash_Table *limited_custodians = NULL;
#ifndef MZ_PRECISE_GC
static int cust_box_count, cust_box_alloc;
static Scheme_Custodian_Box **cust_boxes;
# ifndef USE_SENORA_GC
extern int GC_is_marked(void *);
# endif
#endif
/* On swap, put target in a static variable, instead of on the stack,
so that the swapped-out thread is less likely to have a pointer
to the target thread. */
@ -311,6 +319,8 @@ static Scheme_Object *custodian_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_close_all(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_to_list(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_custodian(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_custodian_box(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_box_value(int argc, Scheme_Object *argv[]);
static Scheme_Object *call_as_nested_thread(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_namespace(int argc, Scheme_Object *args[]);
@ -558,6 +568,16 @@ void scheme_init_thread(Scheme_Env *env)
"current-custodian",
MZCONFIG_CUSTODIAN),
env);
scheme_add_global_constant("make-custodian-box",
scheme_make_prim_w_arity(make_custodian_box,
"make-custodian-box",
2, 2),
env);
scheme_add_global_constant("custodian-box-value",
scheme_make_prim_w_arity(custodian_box_value,
"custodian-box-value",
1, 1),
env);
scheme_add_global_constant("call-in-nested-thread",
scheme_make_prim_w_arity(call_as_nested_thread,
"call-in-nested-thread",
@ -1667,6 +1687,102 @@ static Scheme_Object *current_custodian(int argc, Scheme_Object *argv[])
-1, custodian_p, "custodian", 0);
}
static Scheme_Object *make_custodian_box(int argc, Scheme_Object *argv[])
{
Scheme_Custodian_Box *cb;
if (!SCHEME_CUSTODIANP(argv[0]))
scheme_wrong_type("make-custodian-box", "custodian", 0, argc, argv);
cb = MALLOC_ONE_TAGGED(Scheme_Custodian_Box);
cb->so.type = scheme_cust_box_type;
cb->cust = (Scheme_Custodian *)argv[0];
cb->v = argv[1];
#ifdef MZ_PRECISE_GC
/* 3m */
{
Scheme_Object *wb, *pr;
wb = GC_malloc_weak_box(cb, NULL, 0);
pr = scheme_make_raw_pair(wb, cb->cust->cust_boxes);
cb->cust->cust_boxes = pr;
}
#else
/* CGC */
if (cust_box_count >= cust_box_alloc) {
Scheme_Custodian_Box **cbs;
if (!cust_box_alloc) {
cust_box_alloc = 16;
REGISTER_SO(cust_boxes);
} else {
cust_box_alloc = 2 * cust_box_alloc;
}
cbs = (Scheme_Custodian_Box **)scheme_malloc_atomic(cust_box_alloc * sizeof(Scheme_Custodian_Box *));
memcpy(cbs, cust_boxes, cust_box_count * sizeof(Scheme_Custodian_Box *));
cust_boxes = cbs;
}
cust_boxes[cust_box_count++] = cb;
#endif
return (Scheme_Object *)cb;
}
static Scheme_Object *custodian_box_value(int argc, Scheme_Object *argv[])
{
Scheme_Custodian_Box *cb;
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cust_box_type))
scheme_wrong_type("custodian-box-value", "custodian-box", 0, argc, argv);
cb = (Scheme_Custodian_Box *)argv[0];
if (cb->cust->shut_down)
return scheme_false;
return cb->v;
}
#ifndef MZ_PRECISE_GC
void scheme_clean_cust_box_list(void)
{
int src = 0, dest = 0;
Scheme_Custodian_Box *cb;
void *b;
while (src < cust_box_count) {
cb = cust_boxes[src];
b = GC_base(cb);
if (b
#ifndef USE_SENORA_GC
&& GC_is_marked(b)
#endif
) {
cust_boxes[dest++] = cb;
if (cb->v) {
if (cb->cust->shut_down) {
cb->v = NULL;
}
}
}
src++;
}
cust_box_count = dest;
}
static void shrink_cust_box_array(void)
{
/* Call this function periodically to clean up. */
if (cust_box_alloc > 128 && (cust_box_count * 4 < cust_box_alloc)) {
Scheme_Custodian_Box **cbs;
cust_box_alloc = cust_box_count * 2;
cbs = (Scheme_Custodian_Box **)scheme_malloc_atomic(cust_box_alloc * sizeof(Scheme_Custodian_Box *));
memcpy(cbs, cust_boxes, cust_box_count * sizeof(Scheme_Custodian_Box *));
cust_boxes = cbs;
}
}
#else
# define shrink_cust_box_array() /* empty */
# define clean_cust_box_list() /* empty */
#endif
static void run_closers(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data)
{
@ -3615,6 +3731,8 @@ void scheme_thread_block(float sleep_time)
/* Check scheduled_kills early and often. */
check_scheduled_kills();
shrink_cust_box_array();
if (scheme_active_but_sleeping)
scheme_wake_up();
@ -7104,6 +7222,7 @@ static void register_traversers(void)
{
GC_REG_TRAV(scheme_will_executor_type, mark_will_executor_val);
GC_REG_TRAV(scheme_custodian_type, mark_custodian_val);
GC_REG_TRAV(scheme_cust_box_type, mark_custodian_box_val);
GC_REG_TRAV(scheme_thread_hop_type, mark_thread_hop);
GC_REG_TRAV(scheme_evt_set_type, mark_evt_set);
GC_REG_TRAV(scheme_thread_set_type, mark_thread_set);

1
src/mzscheme/src/type.c
View File

@ -195,6 +195,7 @@ scheme_init_type (Scheme_Env *env)
set_name(scheme_svector_type, "<short-vector>");
set_name(scheme_custodian_type, "<custodian>");
set_name(scheme_cust_box_type, "<custodian-box>");
set_name(scheme_cont_mark_set_type, "<continuation-mark-set>");
set_name(scheme_cont_mark_chain_type, "<chain>");