dnrops
/
gimp
mirror of https://github.com/GNOME/gimp.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Applied changes from CVS version 1.9 of official version of TinyScheme. 

Fix for nasty gc bug. This change shifts the burden of protecting newly
allocated cells in foreign functions from the foreign functions to the
TinyScheme interpreter.
This commit is contained in:
Kevin Cozens 2009-08-07 15:13:12 -04:00
parent 3d848b3917
commit 28e7c3f612
4 changed files with 99 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
plug-ins/script-fu/scheme-wrapper.c
View File

@ -1394,7 +1394,6 @@ script_fu_marshal_procedure_call (scheme *sc,
sc->vptr->mk_integer (sc,
values[i + 1].data.d_int32),
return_val);
set_safe_foreign (sc, return_val);
break;
case GIMP_PDB_INT16:
@ -1402,7 +1401,6 @@ script_fu_marshal_procedure_call (scheme *sc,
sc->vptr->mk_integer (sc,
values[i + 1].data.d_int16),
return_val);
set_safe_foreign (sc, return_val);
break;
case GIMP_PDB_INT8:
@ -1410,7 +1408,6 @@ script_fu_marshal_procedure_call (scheme *sc,
sc->vptr->mk_integer (sc,
values[i + 1].data.d_int8),
return_val);
set_safe_foreign (sc, return_val);
break;
case GIMP_PDB_FLOAT:
@ -1418,7 +1415,6 @@ script_fu_marshal_procedure_call (scheme *sc,
sc->vptr->mk_real (sc,
values[i + 1].data.d_float),
return_val);
set_safe_foreign (sc, return_val);
break;
case GIMP_PDB_STRING:
@ -1428,7 +1424,6 @@ script_fu_marshal_procedure_call (scheme *sc,
return_val = sc->vptr->cons (sc,
sc->vptr->mk_string (sc, string),
return_val);
set_safe_foreign (sc, return_val);
break;
case GIMP_PDB_INT32ARRAY:
@ -1437,15 +1432,14 @@ script_fu_marshal_procedure_call (scheme *sc,
gint32 *array = (gint32 *) values[i + 1].data.d_int32array;
pointer vector = sc->vptr->mk_vector (sc, num_int32s);
return_val = sc->vptr->cons (sc, vector, return_val);
set_safe_foreign (sc, return_val);
for (j = 0; j < num_int32s; j++)
{
sc->vptr->set_vector_elem (vector, j,
sc->vptr->mk_integer (sc,
array[j]));
}
return_val = sc->vptr->cons (sc, vector, return_val);
}
break;
@ -1455,15 +1449,14 @@ script_fu_marshal_procedure_call (scheme *sc,
gint16 *array = (gint16 *) values[i + 1].data.d_int16array;
pointer vector = sc->vptr->mk_vector (sc, num_int16s);
return_val = sc->vptr->cons (sc, vector, return_val);
set_safe_foreign (sc, return_val);
for (j = 0; j < num_int16s; j++)
{
sc->vptr->set_vector_elem (vector, j,
sc->vptr->mk_integer (sc,
array[j]));
}
return_val = sc->vptr->cons (sc, vector, return_val);
}
break;
@ -1473,15 +1466,14 @@ script_fu_marshal_procedure_call (scheme *sc,
guint8 *array = (guint8 *) values[i + 1].data.d_int8array;
pointer vector = sc->vptr->mk_vector (sc, num_int8s);
return_val = sc->vptr->cons (sc, vector, return_val);
set_safe_foreign (sc, return_val);
for (j = 0; j < num_int8s; j++)
{
sc->vptr->set_vector_elem (vector, j,
sc->vptr->mk_integer (sc,
array[j]));
}
return_val = sc->vptr->cons (sc, vector, return_val);
}
break;
@ -1491,15 +1483,14 @@ script_fu_marshal_procedure_call (scheme *sc,
gdouble *array = (gdouble *) values[i + 1].data.d_floatarray;
pointer vector = sc->vptr->mk_vector (sc, num_floats);
return_val = sc->vptr->cons (sc, vector, return_val);
set_safe_foreign (sc, return_val);
for (j = 0; j < num_floats; j++)
{
sc->vptr->set_vector_elem (vector, j,
sc->vptr->mk_real (sc,
array[j]));
}
return_val = sc->vptr->cons (sc, vector, return_val);
}
break;
@ -1509,9 +1500,6 @@ script_fu_marshal_procedure_call (scheme *sc,
gchar **array = (gchar **) values[i + 1].data.d_stringarray;
pointer list = sc->NIL;
return_val = sc->vptr->cons (sc, list, return_val);
set_safe_foreign (sc, return_val);
for (j = num_strings - 1; j >= 0; j--)
{
list = sc->vptr->cons (sc,
@ -1519,14 +1507,9 @@ script_fu_marshal_procedure_call (scheme *sc,
array[j] ?
array[j] : ""),
list);
/* hook the current list into return_val, so that it
* inherits the set_safe_foreign()-protection.
* May be removed when tinyscheme fixes the GC issue
* with foreign functions
*/
sc->vptr->set_car (return_val, list);
}
return_val = sc->vptr->cons (sc, list, return_val);
}
break;
@ -1547,7 +1530,6 @@ script_fu_marshal_procedure_call (scheme *sc,
return_val = sc->vptr->cons (sc,
temp_val,
return_val);
set_safe_foreign (sc, return_val);
break;
}
@ -1557,9 +1539,6 @@ script_fu_marshal_procedure_call (scheme *sc,
GimpRGB *array = (GimpRGB *) values[i + 1].data.d_colorarray;
pointer vector = sc->vptr->mk_vector (sc, num_colors);
return_val = sc->vptr->cons (sc, vector, return_val);
set_safe_foreign (sc, return_val);
for (j = 0; j < num_colors; j++)
{
guchar r, g, b;
@ -1574,11 +1553,10 @@ script_fu_marshal_procedure_call (scheme *sc,
sc->vptr->cons (sc,
sc->vptr->mk_integer (sc, b),
sc->NIL)));
return_val = sc->vptr->cons (sc,
temp_val,
return_val);
set_safe_foreign (sc, return_val);
sc->vptr->set_vector_elem (vector, j, temp_val);
}
return_val = sc->vptr->cons (sc, vector, return_val);
}
break;
@ -1604,7 +1582,6 @@ script_fu_marshal_procedure_call (scheme *sc,
return_val = sc->vptr->cons (sc,
temp_val,
return_val);
set_safe_foreign (sc, return_val);
break;
}
break;
@ -1635,7 +1612,6 @@ script_fu_marshal_procedure_call (scheme *sc,
return_val = sc->vptr->cons (sc,
temp_val,
return_val);
set_safe_foreign (sc, return_val);
#if DEBUG_MARSHALL
g_printerr (" name '%s'\n", p->name);

1
plug-ins/script-fu/tinyscheme/scheme-private.h
View File

@ -69,7 +69,6 @@ pointer args; /* register for arguments of function */
pointer envir; /* stack register for current environment */
pointer code; /* register for current code */
pointer dump; /* stack register for next evaluation */
pointer safe_foreign; /* register to avoid gc problems */
pointer foreign_error; /* used for foreign functions to signal an error */
int interactive_repl; /* are we in an interactive REPL? */

117
plug-ins/script-fu/tinyscheme/scheme.c
View File

@ -656,7 +656,7 @@ static int alloc_cellseg(scheme *sc, int n) {
return n;
}
static INLINE pointer get_cell(scheme *sc, pointer a, pointer b) {
static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
if (sc->free_cell != sc->NIL) {
pointer x = sc->free_cell;
sc->free_cell = cdr(x);
@ -676,8 +676,9 @@ static pointer _get_cell(scheme *sc, pointer a, pointer b) {
}
if (sc->free_cell == sc->NIL) {
const int min_to_be_recovered = sc->last_cell_seg*8;
gc(sc,a, b);
if (sc->fcells < sc->last_cell_seg*8
if (sc->fcells < min_to_be_recovered
|| sc->free_cell == sc->NIL) {
/* if only a few recovered, get more to avoid fruitless gc's */
if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
@ -775,6 +776,76 @@ static pointer find_consecutive_cells(scheme *sc, int n) {
return sc->NIL;
}
/* To retain recent allocs before interpreter knows about them -
Tehom */
static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
{
pointer holder = get_cell_x(sc, recent, extra);
typeflag(holder) = T_PAIR | T_IMMUTABLE;
car(holder) = recent;
cdr(holder) = car(sc->sink);
car(sc->sink) = holder;
}
static pointer get_cell(scheme *sc, pointer a, pointer b)
{
pointer cell = get_cell_x(sc, a, b);
/* For right now, include "a" and "b" in "cell" so that gc doesn't
think they are garbage. */
/* Tentatively record it as a pair so gc understands it. */
typeflag(cell) = T_PAIR;
car(cell) = a;
cdr(cell) = b;
push_recent_alloc(sc, cell, sc->NIL);
return cell;
}
static pointer get_vector_object(scheme *sc, int len, pointer init)
{
pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
if(sc->no_memory) { return sc->sink; }
/* Record it as a vector so that gc understands it. */
typeflag(cells) = (T_VECTOR | T_ATOM);
ivalue_unchecked(cells)=len;
set_num_integer(cells);
fill_vector(cells,init);
push_recent_alloc(sc, cells, sc->NIL);
return cells;
}
static INLINE void ok_to_freely_gc(scheme *sc)
{
car(sc->sink) = sc->NIL;
}
#if defined TSGRIND
static void check_cell_alloced(pointer p, int expect_alloced)
{
/* Can't use putstr(sc,str) because callers have no access to
sc. */
if(typeflag(p) & !expect_alloced)
{
fprintf(stderr,"Cell is already allocated!\n");
}
if(!(typeflag(p)) & expect_alloced)
{
fprintf(stderr,"Cell is not allocated!\n");
}
}
static void check_range_alloced(pointer p, int n, int expect_alloced)
{
int i;
for(i = 0;i<n;i++)
{ (void)check_cell_alloced(p+i,expect_alloced); }
}
#endif
/* Medium level cell allocation */
/* get new cons cell */
pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
pointer x = get_cell(sc,a, b);
@ -939,24 +1010,11 @@ static pointer mk_number(scheme *sc, num n) {
}
}
void set_safe_foreign (scheme *sc, pointer data) {
if (sc->safe_foreign == sc->NIL) {
fprintf (stderr, "get_safe_foreign called outside a foreign function\n");
} else {
car (sc->safe_foreign) = data;
}
}
pointer foreign_error (scheme *sc, const char *s, pointer a) {
if (sc->safe_foreign == sc->NIL) {
fprintf (stderr, "set_foreign_error_flag called outside a foreign function\n");
} else {
sc->foreign_error = cons (sc, mk_string (sc, s), a);
}
sc->foreign_error = cons (sc, mk_string (sc, s), a);
return sc->T;
}
/* char_cnt is length of string in chars. */
/* str points to a NUL terminated string. */
/* Only uses fill_char if str is NULL. */
@ -1009,8 +1067,8 @@ INTERFACE pointer mk_string(scheme *sc, const char *str) {
INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
pointer x = get_cell(sc, sc->NIL, sc->NIL);
strvalue(x) = store_string(sc,len,str,0);
typeflag(x) = (T_STRING | T_ATOM);
strvalue(x) = store_string(sc,len,str,0);
strlength(x) = len;
return (x);
}
@ -1018,21 +1076,14 @@ INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
INTERFACE pointer mk_empty_string(scheme *sc, int len, gunichar fill) {
pointer x = get_cell(sc, sc->NIL, sc->NIL);
strvalue(x) = store_string(sc,len,0,fill);
typeflag(x) = (T_STRING | T_ATOM);
strvalue(x) = store_string(sc,len,0,fill);
strlength(x) = len;
return (x);
}
INTERFACE static pointer mk_vector(scheme *sc, int len) {
pointer x=get_consecutive_cells(sc,len/2+len%2+1);
if(sc->no_memory) { return sc->sink; }
typeflag(x) = (T_VECTOR | T_ATOM);
ivalue_unchecked(x)=len;
set_num_integer(x);
fill_vector(x,sc->NIL);
return x;
}
INTERFACE static pointer mk_vector(scheme *sc, int len)
{ return get_vector_object(sc,len,sc->NIL); }
INTERFACE static void fill_vector(pointer vec, pointer obj) {
int i;
@ -1294,12 +1345,14 @@ static void gc(scheme *sc, pointer a, pointer b) {
mark(sc->code);
dump_stack_mark(sc);
mark(sc->value);
mark(sc->safe_foreign);
mark(sc->inport);
mark(sc->save_inport);
mark(sc->outport);
mark(sc->loadport);
/* Mark recent objects the interpreter doesn't know about yet. */
mark(car(sc->sink));
/* mark variables a, b */
mark(a);
mark(b);
@ -2663,10 +2716,8 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
if (is_proc(sc->code)) {
s_goto(sc,procnum(sc->code)); /* PROCEDURE */
} else if (is_foreign(sc->code)) {
sc->safe_foreign = cons (sc, sc->NIL, sc->safe_foreign);
sc->foreign_error = sc->NIL;
x=sc->code->_object._ff(sc,sc->args);
sc->safe_foreign = cdr (sc->safe_foreign);
if (sc->foreign_error == sc->NIL) {
s_return(sc,x);
} else {
@ -4459,6 +4510,7 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
pcd=dispatch_table+sc->op;
}
}
ok_to_freely_gc(sc);
old_op=sc->op;
if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
return;
@ -4676,7 +4728,6 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
sc->code = sc->NIL;
sc->tracing=0;
sc->bc_flag = 0;
sc->safe_foreign = sc->NIL;
/* init sc->NIL */
typeflag(sc->NIL) = (T_ATOM | MARK);
@ -4687,6 +4738,10 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
/* init F */
typeflag(sc->F) = (T_ATOM | MARK);
car(sc->F) = cdr(sc->F) = sc->F;
/* init sink */
typeflag(sc->sink) = (T_PAIR | MARK);
car(sc->sink) = sc->NIL;
sc->oblist = oblist_initial_value(sc);
/* init global_env */
new_frame_in_env(sc, sc->NIL);

2
plug-ins/script-fu/tinyscheme/scheme.h
View File

@ -168,8 +168,6 @@ void putstr(scheme *sc, const char *s);
int list_length(scheme *sc, pointer a);
int eqv(pointer a, pointer b);
SCHEME_EXPORT void set_safe_foreign (scheme *sc, pointer data);
SCHEME_EXPORT pointer foreign_error (scheme *sc, const char *s, pointer a);
#if USE_INTERFACE