diff -ur a/chicken.h b/chicken.h --- a/chicken.h 2013-03-05 18:55:32.274503594 +0100 +++ b/chicken.h 2013-03-05 18:55:53.590573747 +0100 @@ -1079,7 +1079,7 @@ #if C_STACK_GROWS_DOWNWARD # define C_demand(n) (C_stress && ((C_word)(C_stack_pointer - C_stack_limit) > (n))) -# define C_stack_probe(p) (C_stress && ((C_word *)(p) >= C_stack_limit)) +# define C_stack_probe(p) (C_stress && ((C_word *)(p) >= C_stack_limit) && !C_mutation_limit) # define C_stack_check1(err) if(!C_disable_overflow_check) { \ do { C_byte *_sp = (C_byte*)(C_stack_pointer); \ @@ -1090,7 +1090,7 @@ #else # define C_demand(n) (C_stress && ((C_word)(C_stack_limit - C_stack_pointer) > (n))) -# define C_stack_probe(p) (C_stress && ((C_word *)(p) < C_stack_limit)) +# define C_stack_probe(p) (C_stress && ((C_word *)(p) < C_stack_limit) && !C_mutation_limit) # define C_stack_check1(err) if(!C_disable_overflow_check) { \ do { C_byte *_sp = (C_byte*)(C_stack_pointer); \ @@ -1591,6 +1591,7 @@ C_varextern C_TLS C_byte *C_fromspace_top, *C_fromspace_limit; +C_varextern C_TLS int C_mutation_limit; C_varextern C_TLS jmp_buf C_restart; C_varextern C_TLS void *C_restart_address; C_varextern C_TLS int C_entry_point_status; @@ -1926,8 +1927,9 @@ C_fctexport C_word C_fcall C_i_getprop(C_word sym, C_word prop, C_word def) C_regparm; C_fctexport C_word C_fcall C_putprop(C_word **a, C_word sym, C_word prop, C_word val) C_regparm; C_fctexport C_word C_fcall C_i_get_keyword(C_word key, C_word args, C_word def) C_regparm; -C_fctexport double C_fcall C_milliseconds(void) C_regparm; -C_fctexport double C_fcall C_cpu_milliseconds(void) C_regparm; +typedef long C_time_t; +C_fctexport C_time_t C_fcall C_milliseconds(void) C_regparm; +C_fctexport C_time_t C_fcall C_cpu_milliseconds(void) C_regparm; C_fctexport C_word C_fcall C_a_i_cpu_time(C_word **a, int c, C_word buf) C_regparm; C_fctexport C_word C_fcall C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix) C_regparm; C_fctexport C_word C_fcall C_a_i_exact_to_inexact(C_word **a, int c, C_word n) C_regparm; diff -ur a/runtime.c b/runtime.c --- a/runtime.c 2013-03-05 18:55:32.290503612 +0100 +++ b/runtime.c 2013-03-05 19:11:57.308871896 +0100 @@ -331,6 +331,7 @@ *C_fromspace_limit; C_TLS jmp_buf C_restart; C_TLS void *C_restart_address; +C_TLS int C_mutation_limit = 0; C_TLS int C_entry_point_status; C_TLS int (*C_gc_mutation_hook)(C_word *slot, C_word val); C_TLS void (*C_gc_trace_hook)(C_word *var, int mode); @@ -417,7 +418,7 @@ fake_tty_flag, debug_mode, dump_heap_on_exit, - gc_bell, + gc_bell = 0, gc_report_flag = 0, gc_mode, gc_count_1, @@ -438,7 +439,7 @@ stack_size; static C_TLS int chicken_is_initialized; static C_TLS jmp_buf gc_restart; -static C_TLS double +static C_TLS C_time_t timer_start_ms, gc_ms, timer_accumulated_gc_ms, @@ -451,12 +452,13 @@ locative_table_count, live_finalizer_count, allocated_finalizer_count, + allocated_gc_root_count, pending_finalizer_count, callback_returned_flag; static C_TLS WEAK_TABLE_ENTRY *weak_item_table; -static C_TLS C_GC_ROOT *gc_root_list = NULL; +static C_TLS C_GC_ROOT gc_root_list, *gc_root_free_list; static C_TLS FINALIZER_NODE - *finalizer_list, + finalizer_list, *finalizer_free_list, **pending_finalizer_indices; static C_TLS void *current_module_handle; @@ -487,7 +489,7 @@ static C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int ci) C_regparm; static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm; static double compute_symbol_table_load(double *avg_bucket_len, int *total); -static C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo) C_regparm; +static C_word C_fcall convert_string_to_number(C_char *str, int len, int radix, C_word *fix, double *flo) C_regparm; static C_word C_fcall maybe_inexact_to_exact(C_word n) C_regparm; static void C_fcall remark_system_globals(void) C_regparm; static void C_fcall really_remark(C_word *x) C_regparm; @@ -666,7 +668,7 @@ } /* Initialize finalizer lists: */ - finalizer_list = NULL; + finalizer_list.next = finalizer_list.previous = &finalizer_list; finalizer_free_list = NULL; pending_finalizer_indices = (FINALIZER_NODE **)C_malloc(C_max_pending_finalizers * sizeof(FINALIZER_NODE *)); @@ -697,7 +699,8 @@ collectibles_top = collectibles; collectibles_limit = collectibles + DEFAULT_COLLECTIBLES_SIZE; - gc_root_list = NULL; + gc_root_free_list = NULL; + gc_root_list.next = gc_root_list.prev = &gc_root_list; /* Initialize global variables: */ if(C_trace_buffer_size < MIN_TRACE_BUFFER_SIZE) @@ -759,6 +762,7 @@ C_post_gc_hook = NULL; live_finalizer_count = 0; allocated_finalizer_count = 0; + allocated_gc_root_count = 0; current_module_name = NULL; current_module_handle = NULL; callback_continuation_level = 0; @@ -843,19 +847,25 @@ void *CHICKEN_new_gc_root_2(int finalizable) { - C_GC_ROOT *r = (C_GC_ROOT *)C_malloc(sizeof(C_GC_ROOT)); + C_GC_ROOT *r; - if(r == NULL) - panic(C_text("out of memory - cannot allocate GC root")); + if(gc_root_free_list == NULL) { + if((r = (C_GC_ROOT *)C_malloc(sizeof(C_GC_ROOT))) == NULL) + panic(C_text("out of memory - cannot allocate GC root node")); + ++allocated_gc_root_count; + } else { + r = gc_root_free_list; + gc_root_free_list = gc_root_free_list->next; + } r->value = C_SCHEME_UNDEFINED; - r->next = gc_root_list; - r->prev = NULL; - r->finalizable = finalizable; + r->next = &gc_root_list; + r->prev = gc_root_list.prev; + gc_root_list.prev->next = r; + gc_root_list.prev = r; - if(gc_root_list != NULL) gc_root_list->prev = r; + r->finalizable = finalizable; - gc_root_list = r; return (void *)r; } @@ -876,12 +886,12 @@ { C_GC_ROOT *r = (C_GC_ROOT *)root; - if(r->prev == NULL) gc_root_list = r->next; - else r->prev->next = r->next; - - if(r->next != NULL) r->next->prev = r->prev; + r->prev->next = r->next; + r->next->prev = r->prev; - C_free(root); + /* C_free(root); */ + r->next = gc_root_free_list; + gc_root_free_list = r; } @@ -1174,6 +1184,7 @@ tospace_top = tospace_start; tospace_limit = tospace_start + size; mutation_stack_top = mutation_stack_bottom; + C_mutation_limit = 0; if(reintern) initialize_symbol_table(); } @@ -1805,7 +1816,7 @@ /* Timing routines: */ -C_regparm double C_fcall C_milliseconds(void) +C_regparm C_time_t C_fcall C_milliseconds(void) { #ifdef C_NONUNIX if(CLOCKS_PER_SEC == 1000) return clock(); @@ -1843,7 +1854,7 @@ } -C_regparm double C_fcall C_cpu_milliseconds(void) +C_regparm C_time_t C_fcall C_cpu_milliseconds(void) { #if defined(C_NONUNIX) || defined(__CYGWIN__) if(CLOCKS_PER_SEC == 1000) return clock(); @@ -1935,6 +1946,17 @@ } +C_inline C_regparm int C_i_in_stackp(C_word x) +{ + C_word *ptr = (C_word *)(C_uword)x; + +#if C_STACK_GROWS_DOWNWARD + return ptr >= C_stack_pointer_test && ptr <= stack_bottom; +#else + return ptr < C_stack_pointer_test && ptr >= stack_bottom; +#endif +} + void C_fcall C_callback_adjust_stack(C_word *a, int size) { if(!chicken_is_running && !C_in_stackp((C_word)a)) { @@ -2112,7 +2134,7 @@ key = hash_string(len, str, stable->size, stable->rand, 0); if(C_truep(s = lookup(key, len, str, stable))) { - if(C_in_stackp(s)) C_mutate_slot(slot, s); + if(C_i_in_stackp(s)) C_mutate_slot(slot, s); return s; } @@ -2254,13 +2276,7 @@ C_regparm int C_in_stackp(C_word x) { - C_word *ptr = (C_word *)(C_uword)x; - -#if C_STACK_GROWS_DOWNWARD - return ptr >= C_stack_pointer_test && ptr <= stack_bottom; -#else - return ptr < C_stack_pointer_test && ptr >= stack_bottom; -#endif + return C_i_in_stackp(x); } @@ -2706,6 +2722,8 @@ mutation_stack_top = mutation_stack_bottom + mssize; } + C_mutation_limit = mutation_stack_top - mutation_stack_bottom > (1 << 10); + *(mutation_stack_top++) = slot; ++mutation_count; return *slot = val; @@ -2760,7 +2778,7 @@ C_SCHEME_BLOCK *bp; C_GC_ROOT *gcrp; WEAK_TABLE_ENTRY *wep; - double tgc = 0; + C_time_t tgc = 0; C_SYMBOL_TABLE *stp; volatile int finalizers_checked; FINALIZER_NODE *flist; @@ -2800,6 +2818,7 @@ if(gc_mode == GC_REALLOC) { C_rereclaim2(percentage(heap_size, C_heap_growth), 0); gc_mode = GC_MAJOR; + count = (C_uword)tospace_top - (C_uword)tospace_start; goto i_like_spaghetti; } @@ -2826,7 +2845,7 @@ if(*msp != NULL) mark(*msp); /* mark normal GC roots: */ - for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) { + for(gcrp = gc_root_list.next; gcrp != &gc_root_list; gcrp = gcrp->next) { if(!gcrp->finalizable) mark(&gcrp->value); } @@ -2839,6 +2858,7 @@ /* Clear the mutated slot stack: */ mutation_stack_top = mutation_stack_bottom; + C_mutation_limit = 0; /* Mark live values: */ for(p = C_temporary_stack; p < C_temporary_stack_bottom; mark(p++)); @@ -2893,14 +2913,14 @@ j = fcount = 0; - for(flist = finalizer_list; flist != NULL; flist = flist->next) { + for(flist = finalizer_list.next; flist != &finalizer_list; flist = flist->next) { mark(&flist->item); mark(&flist->finalizer); ++fcount; } /* mark finalizable GC roots: */ - for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) { + for(gcrp = gc_root_list.next; gcrp != &gc_root_list; gcrp = gcrp->next) { if(gcrp->finalizable) mark(&gcrp->value); } @@ -2911,7 +2931,7 @@ j = fcount = 0; /* move into pending */ - for(flist = finalizer_list; flist != NULL; flist = flist->next) { + for(flist = finalizer_list.next; flist != &finalizer_list; flist = flist->next) { if(j < C_max_pending_finalizers) { if(!is_fptr(C_block_header(flist->item))) pending_finalizer_indices[ j++ ] = flist; @@ -2919,13 +2939,13 @@ } /* mark */ - for(flist = finalizer_list; flist != NULL; flist = flist->next) { + for(flist = finalizer_list.next; flist != &finalizer_list; flist = flist->next) { mark(&flist->item); mark(&flist->finalizer); } /* mark finalizable GC roots: */ - for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) { + for(gcrp = gc_root_list.next; gcrp != &gc_root_list; gcrp = gcrp->next) { if(gcrp->finalizable) mark(&gcrp->value); } } @@ -2955,10 +2975,8 @@ C_set_block_item(last, 1 + i * 2, flist->item); C_set_block_item(last, 2 + i * 2, flist->finalizer); - if(flist->previous != NULL) flist->previous->next = flist->next; - else finalizer_list = flist->next; - - if(flist->next != NULL) flist->next->previous = flist->previous; + flist->previous->next = flist->next; + flist->next->previous = flist->previous; flist->next = finalizer_free_list; flist->previous = NULL; @@ -3071,9 +3089,10 @@ C_dbg("GC", C_text("%d locatives (from %d)\n"), locative_table_count, locative_table_size); } - if(gc_mode == GC_MAJOR) gc_count_1 = 0; - - if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, (C_long)tgc); + if(gc_mode == GC_MAJOR) { + gc_count_1 = 0; + if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, tgc); + } /* Unwind stack completely */ #ifdef HAVE_SIGSETJMP @@ -3324,13 +3343,14 @@ for(msp = collectibles; msp < collectibles_top; ++msp) if(*msp != NULL) remark(*msp); - for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) + for(gcrp = gc_root_list.next; gcrp != &gc_root_list; gcrp = gcrp->next) remark(&gcrp->value); remark_system_globals(); /* Clear the mutated slot stack: */ mutation_stack_top = mutation_stack_bottom; + C_mutation_limit = 0; /* Mark live values: */ for(p = C_temporary_stack; p < C_temporary_stack_bottom; remark(p++)); @@ -3340,7 +3360,7 @@ remark(&locative_table[ i ]); /* Mark finalizer table: */ - for(flist = finalizer_list; flist != NULL; flist = flist->next) { + for(flist = finalizer_list.next; flist != &finalizer_list; flist = flist->next) { remark(&flist->item); remark(&flist->finalizer); } @@ -3534,7 +3554,7 @@ if(is_fptr(h)) /* forwarded? update l-table entry */ loc = locative_table[ i ] = fptr_to_ptr(h); /* otherwise it must have been GC'd (since this is a minor one) */ - else if(C_in_stackp(loc)) { + else if(C_i_in_stackp(loc)) { locative_table[ i ] = C_SCHEME_UNDEFINED; C_set_block_item(loc, 0, 0); ++invalidated; @@ -3551,7 +3571,7 @@ C_set_block_item(loc, 0, (C_uword)fptr_to_ptr(h) + offset); hi = i + 1; } - else if(C_in_stackp(obj)) { /* pointed-at object GC'd, locative is invalid */ + else if(C_i_in_stackp(obj)) { /* pointed-at object GC'd, locative is invalid */ locative_table[ i ] = C_SCHEME_UNDEFINED; C_set_block_item(loc, 0, 0); } @@ -3650,7 +3670,7 @@ { C_word *p, x, n; int i; - double c; + C_time_t c; /* Build vector with context information: */ n = C_temporary_stack_bottom - C_temporary_stack; @@ -4056,7 +4076,7 @@ void C_ccall C_stop_timer(C_word c, C_word closure, C_word k) { - double t0 = C_cpu_milliseconds() - timer_start_ms; + C_time_t t0 = C_cpu_milliseconds() - timer_start_ms; C_word ab[ WORDS_PER_FLONUM * 2 + 6 ], /* 2 flonums, 1 vector of 5 elements */ *a = ab, @@ -4194,7 +4214,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor) { int i, j; - double tgc; + C_time_t tgc; switch(fudge_factor) { case C_fix(1): return C_SCHEME_END_OF_FILE; /* eof object */ @@ -4577,22 +4597,26 @@ C_word C_a_i_list(C_word **a, int c, ...) { va_list v; - C_word x, last, current, - first = C_SCHEME_END_OF_LIST; + C_word x, last, current, first; - va_start(v, c); + if(c--) { + va_start(v, c); - for(last = C_SCHEME_UNDEFINED; c--; last = current) { x = va_arg(v, C_word); - current = C_a_pair(a, x, C_SCHEME_END_OF_LIST); + first = last = C_a_pair(a, x, C_SCHEME_END_OF_LIST); + for(; c--; last = current) { + x = va_arg(v, C_word); + current = C_a_pair(a, x, C_SCHEME_END_OF_LIST); - if(last != C_SCHEME_UNDEFINED) C_set_block_item(last, 1, current); - else first = current; - } + } - va_end(v); - return first; + va_end(v); + + return first; + } else { + return C_SCHEME_END_OF_LIST; + } } @@ -7420,13 +7444,12 @@ if((n = C_header_size(str)) == 0) { fail: - n = C_SCHEME_FALSE; - goto fini; + return C_SCHEME_FALSE; } if(n >= STRING_BUFFER_SIZE - 1) goto fail; - C_memcpy(sptr = buffer, C_c_string(str), n > (STRING_BUFFER_SIZE - 1) ? STRING_BUFFER_SIZE : n); + C_memcpy(sptr = buffer, C_c_string(str), n); buffer[ n ] = '\0'; if (n != strlen(buffer)) /* Don't barf; this is simply invalid number syntax */ goto fail; @@ -7447,7 +7470,7 @@ /* Scan for embedded special characters and do basic sanity checking: */ for(eptr = sptr, rptr = sptr; *eptr != '\0'; ++eptr) { - switch(C_tolower((int)*eptr)) { + switch(*eptr) { case '.': if(periodf || ratf || expf) goto fail; @@ -7470,11 +7493,11 @@ ratf = 1; rptr = eptr+1; break; - case 'e': - case 'd': - case 'f': - case 'l': - case 's': + case 'e': case 'E': + case 'd': case 'D': + case 'f': case 'F': + case 'l': case 'L': + case 's': case 'S': /* Don't set exp flag if we see the "f" in "inf.0" (preceded by 'n') */ /* Other failure modes are handled elsewhere. */ if(radix == 10 && eptr > sptr && C_tolower((int)*(eptr-1)) != 'n') { @@ -7495,15 +7518,13 @@ /* check for rational representation: */ if(rptr != sptr) { if (*(rptr) == '-' || *(rptr) == '+') { - n = C_SCHEME_FALSE; - goto fini; + return C_SCHEME_FALSE; } *(rptr-1) = '\0'; - switch(convert_string_to_number(sptr, radix, &n1, &fn1)) { + switch(convert_string_to_number(sptr, n - (sptr - buffer), radix, &n1, &fn1)) { case 0: - n = C_SCHEME_FALSE; - goto fini; + return C_SCHEME_FALSE; case 1: fn1 = (double)n1; @@ -7514,9 +7535,9 @@ sptr = rptr; } - + /* convert number and return result: */ - switch(convert_string_to_number(sptr, radix, &n, &fn)) { + switch(convert_string_to_number(sptr, n - (sptr - buffer), radix, &n, &fn)) { case 0: /* failed */ n = C_SCHEME_FALSE; break; @@ -7539,7 +7560,6 @@ break; } - fini: return n; } @@ -7567,13 +7587,12 @@ } -C_regparm C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo) +C_regparm C_word C_fcall convert_string_to_number(C_char *str, int len, int radix, C_word *fix, double *flo) { C_ulong ln; C_word n; C_char *eptr, *eptr2; double fn; - int len = C_strlen(str); if(radix == 10) { if (len == 6) { @@ -7598,11 +7617,11 @@ } } - if(C_strpbrk(str, "xX\0") != NULL) return 0; + if(C_strpbrk(str, "xX") != NULL) return 0; errno = 0; n = C_strtow(str, &eptr, radix); - + if(((n == C_LONG_MAX || n == C_LONG_MIN) && errno == ERANGE) || *eptr != '\0') { if(radix != 10) return from_n_nary(str, radix, flo) ? 2 : 0; @@ -7612,7 +7631,7 @@ if(fn == HUGE_VAL && errno == ERANGE) return 0; else if(eptr2 == str) return 0; - else if(*eptr2 == '\0' || (eptr != eptr2 && !C_strncmp(eptr2, ".0", C_strlen(eptr2)))) { + else if(*eptr2 == '\0' || (eptr != eptr2 && !C_strncmp(eptr2, ".0", len - (eptr2-str)))) { *flo = fn; return 2; } @@ -7620,7 +7639,7 @@ return 0; } else if((n & C_INT_SIGN_BIT) != ((n << 1) & C_INT_SIGN_BIT)) { /* doesn't fit into fixnum? */ - if(*eptr == '\0' || !C_strncmp(eptr, ".0", C_strlen(eptr))) { + if(*eptr == '\0' || !C_strncmp(eptr, ".0", len - (eptr-str))) { *flo = (double)n; return 2; } @@ -8206,16 +8225,15 @@ finalizer_free_list = flist->next; } - if(finalizer_list != NULL) finalizer_list->previous = flist; - - flist->previous = NULL; - flist->next = finalizer_list; - finalizer_list = flist; + flist->next = &finalizer_list; + flist->previous = finalizer_list.previous; + finalizer_list.previous->next = flist; + finalizer_list.previous = flist; - if(C_in_stackp(x)) C_mutate_slot(&flist->item, x); + if(C_i_in_stackp(x)) C_mutate(&flist->item, x); else flist->item = x; - if(C_in_stackp(proc)) C_mutate_slot(&flist->finalizer, proc); + if(C_i_in_stackp(proc)) C_mutate(&flist->finalizer, proc); else flist->finalizer = proc; ++live_finalizer_count; @@ -8227,10 +8245,10 @@ int n; FINALIZER_NODE *flist; - for(flist = finalizer_list; flist != NULL; flist = flist->next) { + for(flist = finalizer_list.next; flist != &finalizer_list; flist = flist->next) { if(flist->item == x) { - if(flist->previous == NULL) finalizer_list = flist->next; - else flist->previous->next = flist->next; + flist->previous->next = flist->next; + flist->next->previous = flist->previous; return 1; } @@ -8981,7 +8999,7 @@ C_word ln; double fn; - switch (convert_string_to_number(*str, 10, &ln, &fn)) { + switch (convert_string_to_number(*str, C_strlen(*str), 10, &ln, &fn)) { case 0: /* failed */ panic(C_text("invalid encoded numeric literal")); break;