diff options
| -rw-r--r-- | tests/gpgscm/scheme-private.h | 5 | ||||
| -rw-r--r-- | tests/gpgscm/scheme.c | 291 |
2 files changed, 252 insertions, 44 deletions
diff --git a/tests/gpgscm/scheme-private.h b/tests/gpgscm/scheme-private.h index 884889c43..aa7889441 100644 --- a/tests/gpgscm/scheme-private.h +++ b/tests/gpgscm/scheme-private.h @@ -121,6 +121,11 @@ pointer COMPILE_HOOK; /* *compile-hook* */ pointer free_cell; /* pointer to top of free cells */ long fcells; /* # of free cells */ +size_t inhibit_gc; /* nesting of gc_disable */ +size_t reserved_cells; /* # of reserved cells */ +#ifndef NDEBUG +int reserved_lineno; /* location of last reservation */ +#endif pointer inport; pointer outport; diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c index 146b9e679..ce31f8d30 100644 --- a/tests/gpgscm/scheme.c +++ b/tests/gpgscm/scheme.c @@ -653,13 +653,119 @@ static int alloc_cellseg(scheme *sc, int n) { return n; } + + +/* Controlling the garbage collector. + * + * Every time a cell is allocated, the interpreter may run out of free + * cells and do a garbage collection. This is problematic because it + * might garbage collect objects that have been allocated, but are not + * yet made available to the interpreter. + * + * Previously, we would plug such newly allocated cells into the list + * of newly allocated objects rooted at car(sc->sink), but that + * requires allocating yet another cell increasing pressure on the + * memory management system. + * + * A faster alternative is to preallocate the cells needed for an + * operation and make sure the garbage collection is not run until all + * allocated objects are plugged in. This can be done with gc_disable + * and gc_enable. + */ + +/* The garbage collector is enabled if the inhibit counter is + * zero. */ +#define GC_ENABLED 0 + +/* For now we provide a way to disable this optimization for + * benchmarking and because it produces slightly smaller code. */ +#ifndef USE_GC_LOCKING +# define USE_GC_LOCKING 1 +#endif + +/* To facilitate nested calls to gc_disable, functions that allocate + * more than one cell may define a macro, e.g. foo_allocates. This + * macro can be used to compute the amount of preallocation at the + * call site with the help of this macro. */ +#define gc_reservations(fn) fn ## _allocates + +#if USE_GC_LOCKING + +/* Report a shortage in reserved cells, and terminate the program. */ +static void +gc_reservation_failure(struct scheme *sc) +{ +#ifdef NDEBUG + fprintf(stderr, + "insufficient reservation\n") +#else + fprintf(stderr, + "insufficient reservation in line %d\n", + sc->reserved_lineno); +#endif + abort(); +} + +/* Disable the garbage collection and reserve the given number of + * cells. gc_disable may be nested, but the enclosing reservation + * must include the reservations of all nested calls. */ +static void +_gc_disable(struct scheme *sc, size_t reserve, int lineno) +{ + if (sc->inhibit_gc == 0) { + reserve_cells(sc, (reserve)); + sc->reserved_cells = (reserve); +#ifndef NDEBUG + (void) lineno; +#else + sc->reserved_lineno = lineno; +#endif + } else if (sc->reserved_cells < (reserve)) + gc_reservation_failure (sc); + sc->inhibit_gc += 1; +} +#define gc_disable(sc, reserve) \ + _gc_disable (sc, reserve, __LINE__) + +/* Enable the garbage collector. */ +#define gc_enable(sc) \ + do { \ + assert(sc->inhibit_gc); \ + sc->inhibit_gc -= 1; \ + } while (0) + +/* Test whether the garbage collector is enabled. */ +#define gc_enabled(sc) \ + (sc->inhibit_gc == GC_ENABLED) + +/* Consume a reserved cell. */ +#define gc_consume(sc) \ + do { \ + assert(! gc_enabled (sc)); \ + if (sc->reserved_cells == 0) \ + gc_reservation_failure (sc); \ + sc->reserved_cells -= 1; \ + } while (0) + +#else /* USE_GC_LOCKING */ + +#define gc_disable(sc, reserve) (void) 0 +#define gc_enable(sc) (void) 0 +#define gc_enabled(sc) 1 +#define gc_consume(sc) (void) 0 + +#endif /* USE_GC_LOCKING */ + static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) { - if (sc->free_cell != sc->NIL) { + if (! gc_enabled (sc) || sc->free_cell != sc->NIL) { pointer x = sc->free_cell; + if (! gc_enabled (sc)) + gc_consume (sc); sc->free_cell = cdr(x); --sc->fcells; return (x); } + assert (gc_enabled (sc)); return _get_cell (sc, a, b); } @@ -672,6 +778,7 @@ static pointer _get_cell(scheme *sc, pointer a, pointer b) { return sc->sink; } + assert (gc_enabled (sc)); if (sc->free_cell == sc->NIL) { const int min_to_be_recovered = sc->last_cell_seg*8; gc(sc,a, b); @@ -826,7 +933,8 @@ static pointer get_cell(scheme *sc, pointer a, pointer b) typeflag(cell) = T_PAIR; car(cell) = a; cdr(cell) = b; - push_recent_alloc(sc, cell, sc->NIL); + if (gc_enabled (sc)) + push_recent_alloc(sc, cell, sc->NIL); return cell; } @@ -839,7 +947,8 @@ static pointer get_vector_object(scheme *sc, int len, pointer init) ivalue_unchecked(cells)=len; set_num_integer(cells); fill_vector(cells,init); - push_recent_alloc(sc, cells, sc->NIL); + if (gc_enabled (sc)) + push_recent_alloc(sc, cells, sc->NIL); return cells; } @@ -896,9 +1005,11 @@ static pointer oblist_initial_value(scheme *sc) /* returns the new symbol */ static pointer oblist_add_by_name(scheme *sc, const char *name) { +#define oblist_add_by_name_allocates 3 pointer x; int location; + gc_disable(sc, gc_reservations (oblist_add_by_name)); x = immutable_cons(sc, mk_string(sc, name), sc->NIL); typeflag(x) = T_SYMBOL; setimmutable(car(x)); @@ -906,6 +1017,7 @@ static pointer oblist_add_by_name(scheme *sc, const char *name) location = hash_fn(name, ivalue_unchecked(sc->oblist)); set_vector_elem(sc->oblist, location, immutable_cons(sc, x, vector_elem(sc->oblist, location))); + gc_enable(sc); return x; } @@ -1115,6 +1227,7 @@ INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { /* get new symbol */ INTERFACE pointer mk_symbol(scheme *sc, const char *name) { +#define mk_symbol_allocates oblist_add_by_name_allocates pointer x; /* first check oblist */ @@ -1345,6 +1458,8 @@ static void gc(scheme *sc, pointer a, pointer b) { pointer p; int i; + assert (gc_enabled (sc)); + if(sc->gc_verbose) { putstr(sc, "gc..."); } @@ -2296,14 +2411,19 @@ static void new_frame_in_env(scheme *sc, pointer old_env) new_frame = sc->NIL; } + gc_disable(sc, 1); sc->envir = immutable_cons(sc, new_frame, old_env); + gc_enable(sc); setenvironment(sc->envir); } static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, pointer variable, pointer value) { - pointer slot = immutable_cons(sc, variable, value); +#define new_slot_spec_in_env_allocates 2 + pointer slot; + gc_disable(sc, gc_reservations (new_slot_spec_in_env)); + slot = immutable_cons(sc, variable, value); if (is_vector(car(env))) { int location = hash_fn(symname(variable), ivalue_unchecked(car(env))); @@ -2313,6 +2433,7 @@ static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, } else { car(env) = immutable_cons(sc, slot, car(env)); } + gc_enable(sc); } static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) @@ -2385,6 +2506,7 @@ static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) { +#define new_slot_in_env_allocates new_slot_spec_in_env_allocates new_slot_spec_in_env(sc, sc->envir, variable, value); } @@ -2488,7 +2610,13 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { #define CASE(OP) case OP #endif /* USE_THREADED_CODE */ -#define s_return(sc,a) return _s_return(sc,a) +/* Return to the previous frame on the dump stack, setting the current + * value to A. */ +#define s_return(sc, a) return _s_return(sc, a, 0) + +/* Return to the previous frame on the dump stack, setting the current + * value to A, and re-enable the garbage collector. */ +#define s_return_enable_gc(sc, a) return _s_return(sc, a, 1) static INLINE void dump_stack_reset(scheme *sc) { @@ -2505,10 +2633,12 @@ static void dump_stack_free(scheme *sc) sc->dump = sc->NIL; } -static pointer _s_return(scheme *sc, pointer a) { +static pointer _s_return(scheme *sc, pointer a, int enable_gc) { pointer dump = sc->dump; pointer op; sc->value = (a); + if (enable_gc) + gc_enable(sc); if (dump == sc->NIL) return sc->NIL; free_cons(sc, dump, &op, &dump); @@ -2520,9 +2650,13 @@ static pointer _s_return(scheme *sc, pointer a) { } static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { - sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); - sc->dump = cons(sc, (args), sc->dump); - sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump); +#define s_save_allocates 5 + pointer dump; + gc_disable(sc, gc_reservations (s_save)); + dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); + dump = cons(sc, (args), dump); + sc->dump = cons(sc, mk_integer(sc, (long)(op)), dump); + gc_enable(sc); } static INLINE void dump_stack_mark(scheme *sc) @@ -2650,8 +2784,10 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { CASE(OP_E0ARGS): /* eval arguments */ if (is_macro(sc->value)) { /* macro expansion */ + gc_disable(sc, 1 + gc_reservations (s_save)); s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); sc->args = cons(sc,sc->code, sc->NIL); + gc_enable(sc); sc->code = sc->value; s_thread_to(sc,OP_APPLY); } else { @@ -2660,7 +2796,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } CASE(OP_E1ARGS): /* eval arguments */ - sc->args = cons(sc, sc->value, sc->args); + gc_disable(sc, 1); + sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); if (is_pair(sc->code)) { /* continue */ s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); sc->code = car(sc->code); @@ -2677,7 +2815,8 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { CASE(OP_TRACING): { int tr=sc->tracing; sc->tracing=ivalue(car(sc->args)); - s_return(sc,mk_integer(sc,tr)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, tr)); } #endif @@ -2749,19 +2888,23 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { sc->value = sc->code; /* Fallthru */ } else { + gc_disable(sc, 1 + gc_reservations (s_save)); s_save(sc,OP_LAMBDA1,sc->args,sc->code); sc->args=cons(sc,sc->code,sc->NIL); + gc_enable(sc); sc->code=slot_value_in_env(f); s_thread_to(sc,OP_APPLY); } } CASE(OP_LAMBDA1): - s_return(sc,mk_closure(sc, sc->value, sc->envir)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir)); #else CASE(OP_LAMBDA): /* lambda */ - s_return(sc,mk_closure(sc, sc->code, sc->envir)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_closure(sc, sc->code, sc->envir)); #endif @@ -2775,7 +2918,8 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { } else { y=cadr(sc->args); } - s_return(sc,mk_closure(sc, x, y)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_closure(sc, x, y)); CASE(OP_QUOTE): /* quote */ s_return(sc,car(sc->code)); @@ -2786,7 +2930,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { if (is_pair(car(sc->code))) { x = caar(sc->code); + gc_disable(sc, 2); sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + gc_enable(sc); } else { x = car(sc->code); sc->code = cadr(sc->code); @@ -2861,6 +3007,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_thread_to(sc,OP_LET1); CASE(OP_LET1): /* let (calculate parameters) */ + gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0)); sc->args = cons(sc, sc->value, sc->args); if (is_pair(sc->code)) { /* continue */ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { @@ -2868,10 +3015,12 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { car(sc->code)); } s_save(sc,OP_LET1, sc->args, cdr(sc->code)); + gc_enable(sc); sc->code = cadar(sc->code); sc->args = sc->NIL; s_thread_to(sc,OP_EVAL); } else { /* end */ + gc_enable(sc); sc->args = reverse_in_place(sc, sc->NIL, sc->args); sc->code = car(sc->args); sc->args = cdr(sc->args); @@ -2890,10 +3039,14 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { Error_1(sc, "Bad syntax of binding in let :", x); if (!is_list(sc, car(x))) Error_1(sc, "Bad syntax of binding in let :", car(x)); + gc_disable(sc, 1); sc->args = cons(sc, caar(x), sc->args); + gc_enable(sc); } + gc_disable(sc, 2 + gc_reservations (new_slot_in_env)); x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); new_slot_in_env(sc, car(sc->code), x); + gc_enable(sc); sc->code = cddr(sc->code); sc->args = sc->NIL; } else { @@ -2951,7 +3104,9 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { s_thread_to(sc,OP_LET1REC); CASE(OP_LET1REC): /* letrec (calculate parameters) */ + gc_disable(sc, 1); sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); if (is_pair(sc->code)) { /* continue */ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { Error_1(sc, "Bad syntax of binding spec in letrec :", @@ -2993,8 +3148,10 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { if(!is_pair(cdr(sc->code))) { Error_0(sc,"syntax error in cond"); } + gc_disable(sc, 4); x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); + gc_enable(sc); s_goto(sc,OP_EVAL); } s_goto(sc,OP_BEGIN); @@ -3009,9 +3166,10 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { } CASE(OP_DELAY): /* delay */ + gc_disable(sc, 2); x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); typeflag(x)=T_PROMISE; - s_return(sc,x); + s_return_enable_gc(sc,x); CASE(OP_AND0): /* and */ if (sc->code == sc->NIL) { @@ -3058,14 +3216,17 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { CASE(OP_C1STREAM): /* cons-stream */ sc->args = sc->value; /* save sc->value to register sc->args for gc */ + gc_disable(sc, 3); x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); typeflag(x)=T_PROMISE; - s_return(sc,cons(sc, sc->args, x)); + s_return_enable_gc(sc, cons(sc, sc->args, x)); CASE(OP_MACRO0): /* macro */ if (is_pair(car(sc->code))) { x = caar(sc->code); + gc_disable(sc, 2); sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + gc_enable(sc); } else { x = car(sc->code); sc->code = cadr(sc->code); @@ -3140,7 +3301,9 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { CASE(OP_CONTINUATION): /* call-with-current-continuation */ sc->code = car(sc->args); + gc_disable(sc, 2); sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); + gc_enable(sc); s_goto(sc,OP_APPLY); default: @@ -3270,14 +3433,16 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { for (x = sc->args; x != sc->NIL; x = cdr(x)) { v=num_add(v,nvalue(car(x))); } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_MUL): /* * */ v=num_one; for (x = sc->args; x != sc->NIL; x = cdr(x)) { v=num_mul(v,nvalue(car(x))); } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_SUB): /* - */ if(cdr(sc->args)==sc->NIL) { @@ -3290,7 +3455,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { for (; x != sc->NIL; x = cdr(x)) { v=num_sub(v,nvalue(car(x))); } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_DIV): /* / */ if(cdr(sc->args)==sc->NIL) { @@ -3307,7 +3473,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"/: division by zero"); } } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_INTDIV): /* quotient */ if(cdr(sc->args)==sc->NIL) { @@ -3324,7 +3491,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { Error_0(sc,"quotient: division by zero"); } } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_REM): /* remainder */ v = nvalue(car(sc->args)); @@ -3333,7 +3501,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { else { Error_0(sc,"remainder: division by zero"); } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_MOD): /* modulo */ v = nvalue(car(sc->args)); @@ -3342,7 +3511,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { else { Error_0(sc,"modulo: division by zero"); } - s_return(sc,mk_number(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_number(sc, v)); CASE(OP_CAR): /* car */ s_return(sc,caar(sc->args)); @@ -3373,31 +3543,36 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { CASE(OP_CHAR2INT): { /* char->integer */ char c; c=(char)ivalue(car(sc->args)); - s_return(sc,mk_integer(sc,(unsigned char)c)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c)); } CASE(OP_INT2CHAR): { /* integer->char */ unsigned char c; c=(unsigned char)ivalue(car(sc->args)); - s_return(sc,mk_character(sc,(char)c)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); } CASE(OP_CHARUPCASE): { unsigned char c; c=(unsigned char)ivalue(car(sc->args)); c=toupper(c); - s_return(sc,mk_character(sc,(char)c)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); } CASE(OP_CHARDNCASE): { unsigned char c; c=(unsigned char)ivalue(car(sc->args)); c=tolower(c); - s_return(sc,mk_character(sc,(char)c)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_character(sc, (char) c)); } CASE(OP_STR2SYM): /* string->symbol */ - s_return(sc,mk_symbol(sc,strvalue(car(sc->args)))); + gc_disable(sc, gc_reservations (mk_symbol)); + s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args)))); CASE(OP_STR2ATOM): /* string->atom */ { char *s=strvalue(car(sc->args)); @@ -3435,9 +3610,10 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } CASE(OP_SYM2STR): /* symbol->string */ + gc_disable(sc, 1); x=mk_string(sc,symname(car(sc->args))); setimmutable(x); - s_return(sc,x); + s_return_enable_gc(sc, x); CASE(OP_ATOM2STR): /* atom->string */ { long pf = 0; @@ -3459,7 +3635,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { char *p; int len; atom2str(sc,x,(int )pf,&p,&len); - s_return(sc,mk_counted_string(sc,p,len)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_counted_string(sc, p, len)); } else { Error_1(sc, "atom->string: not an atom:", x); } @@ -3474,11 +3651,13 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { if(cdr(sc->args)!=sc->NIL) { fill=charvalue(cadr(sc->args)); } - s_return(sc,mk_empty_string(sc,len,(char)fill)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill)); } CASE(OP_STRLEN): /* string-length */ - s_return(sc,mk_integer(sc,strlength(car(sc->args)))); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args)))); CASE(OP_STRREF): { /* string-ref */ char *str; @@ -3492,7 +3671,9 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { Error_1(sc,"string-ref: out of bounds:",cadr(sc->args)); } - s_return(sc,mk_character(sc,((unsigned char*)str)[index])); + gc_disable(sc, 1); + s_return_enable_gc(sc, + mk_character(sc, ((unsigned char*) str)[index])); } CASE(OP_STRSET): { /* string-set! */ @@ -3526,13 +3707,14 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { for (x = sc->args; x != sc->NIL; x = cdr(x)) { len += strlength(car(x)); } + gc_disable(sc, 1); newstr = mk_empty_string(sc, len, ' '); /* store the contents of the argument strings into the new string */ for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; pos += strlength(car(x)), x = cdr(x)) { memcpy(pos, strvalue(car(x)), strlength(car(x))); } - s_return(sc, newstr); + s_return_enable_gc(sc, newstr); } CASE(OP_SUBSTR): { /* substring */ @@ -3559,11 +3741,12 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } len=index1-index0; + gc_disable(sc, 1); x=mk_empty_string(sc,len,' '); memcpy(strvalue(x),str+index0,len); strvalue(x)[len]=0; - s_return(sc,x); + s_return_enable_gc(sc, x); } CASE(OP_VECTOR): { /* vector */ @@ -3600,7 +3783,8 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { } CASE(OP_VECLEN): /* vector-length */ - s_return(sc,mk_integer(sc,ivalue(car(sc->args)))); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, ivalue(car(sc->args)))); CASE(OP_VECREF): { /* vector-ref */ int index; @@ -4173,7 +4357,9 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { break; CASE(OP_RDLIST): { + gc_disable(sc, 1); sc->args = cons(sc, sc->value, sc->args); + gc_enable(sc); sc->tok = token(sc); if (sc->tok == TOK_EOF) { s_return(sc,sc->EOF_OBJ); } @@ -4206,23 +4392,32 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { } CASE(OP_RDQUOTE): - s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL))); + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->QUOTE, + cons(sc, sc->value, sc->NIL))); CASE(OP_RDQQUOTE): - s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL))); + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->QQUOTE, + cons(sc, sc->value, sc->NIL))); CASE(OP_RDQQUOTEVEC): - s_return(sc,cons(sc, mk_symbol(sc,"apply"), + gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol)); + s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"), cons(sc, mk_symbol(sc,"vector"), cons(sc,cons(sc, sc->QQUOTE, cons(sc,sc->value,sc->NIL)), sc->NIL)))); CASE(OP_RDUNQUOTE): - s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL))); + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->UNQUOTE, + cons(sc, sc->value, sc->NIL))); CASE(OP_RDUQTSP): - s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL))); + gc_disable(sc, 2); + s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP, + cons(sc, sc->value, sc->NIL))); CASE(OP_RDVEC): /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); @@ -4324,7 +4519,8 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { if(v<0) { Error_1(sc,"length: not a list:",car(sc->args)); } - s_return(sc,mk_integer(sc, v)); + gc_disable(sc, 1); + s_return_enable_gc(sc, mk_integer(sc, v)); CASE(OP_ASSQ): /* assq */ /* a.k */ x = car(sc->args); @@ -4347,9 +4543,13 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { if (sc->args == sc->NIL) { s_return(sc,sc->F); } else if (is_closure(sc->args)) { - s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); + gc_disable(sc, 1); + s_return_enable_gc(sc, cons(sc, sc->LAMBDA, + closure_code(sc->value))); } else if (is_macro(sc->args)) { - s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); + gc_disable(sc, 1); + s_return_enable_gc(sc, cons(sc, sc->LAMBDA, + closure_code(sc->value))); } else { s_return(sc,sc->F); } @@ -4705,6 +4905,9 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { sc->EOF_OBJ=&sc->_EOF_OBJ; sc->free_cell = &sc->_NIL; sc->fcells = 0; + sc->inhibit_gc = GC_ENABLED; + sc->reserved_cells = 0; + sc->reserved_lineno = 0; sc->no_memory=0; sc->inport=sc->NIL; sc->outport=sc->NIL; |