[gimp/gimp-2-6] Applied changes from CVS version 1.9 of official version of TinyScheme. Fix for nasty gc bug. This c
- From: Kevin Cozens <kcozens src gnome org>
- To: commits-list gnome org
- Cc:
- Subject: [gimp/gimp-2-6] Applied changes from CVS version 1.9 of official version of TinyScheme. Fix for nasty gc bug. This c
- Date: Thu, 16 Sep 2010 20:02:20 +0000 (UTC)
commit 24b76d01e0c53d4f64e81c5f43ffd23f471ca1ab
Author: Kevin Cozens <kcozens cvs gnome org>
Date: Thu Sep 16 12:11:09 2010 -0400
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.
(cherry pick of commit 28e7c3f612a4d89c73e1f9f95f5469d9e44340e6)
plug-ins/script-fu/scheme-wrapper.c | 50 +++--------
plug-ins/script-fu/tinyscheme/scheme-private.h | 1 -
plug-ins/script-fu/tinyscheme/scheme.c | 117 +++++++++++++++++------
plug-ins/script-fu/tinyscheme/scheme.h | 2 -
4 files changed, 99 insertions(+), 71 deletions(-)
---
diff --git a/plug-ins/script-fu/scheme-wrapper.c b/plug-ins/script-fu/scheme-wrapper.c
index e3daad6..d3deb5e 100644
--- a/plug-ins/script-fu/scheme-wrapper.c
+++ b/plug-ins/script-fu/scheme-wrapper.c
@@ -1395,7 +1395,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:
@@ -1403,7 +1402,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:
@@ -1411,7 +1409,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:
@@ -1419,7 +1416,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:
@@ -1429,7 +1425,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:
@@ -1438,15 +1433,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;
@@ -1456,15 +1450,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;
@@ -1474,15 +1467,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;
@@ -1492,15 +1484,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;
@@ -1510,9 +1501,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,
@@ -1520,14 +1508,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;
@@ -1548,7 +1531,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;
}
@@ -1558,9 +1540,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;
@@ -1575,11 +1554,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;
@@ -1605,7 +1583,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;
@@ -1636,7 +1613,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);
diff --git a/plug-ins/script-fu/tinyscheme/scheme-private.h b/plug-ins/script-fu/tinyscheme/scheme-private.h
index 8607a33..f3e9267 100644
--- a/plug-ins/script-fu/tinyscheme/scheme-private.h
+++ b/plug-ins/script-fu/tinyscheme/scheme-private.h
@@ -68,7 +68,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? */
diff --git a/plug-ins/script-fu/tinyscheme/scheme.c b/plug-ins/script-fu/tinyscheme/scheme.c
index c38014d..457ca28 100644
--- a/plug-ins/script-fu/tinyscheme/scheme.c
+++ b/plug-ins/script-fu/tinyscheme/scheme.c
@@ -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);
@@ -2608,10 +2661,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 {
@@ -4353,6 +4404,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;
@@ -4570,7 +4622,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);
@@ -4581,6 +4632,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);
diff --git a/plug-ins/script-fu/tinyscheme/scheme.h b/plug-ins/script-fu/tinyscheme/scheme.h
index ff81877..92edba6 100644
--- a/plug-ins/script-fu/tinyscheme/scheme.h
+++ b/plug-ins/script-fu/tinyscheme/scheme.h
@@ -164,8 +164,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
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]
