summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/ChangeLog15
-rw-r--r--libguile/gc.c124
-rw-r--r--libguile/struct.c46
-rw-r--r--libguile/struct.h17
4 files changed, 114 insertions, 88 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index b99cd7f1a..d4e757a37 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,5 +1,20 @@
2000-04-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+ * struct.c (scm_alloc_struct, scm_struct_free_0,
+ scm_struct_free_light, scm_struct_free_standard,
+ scm_struct_free_entity, scm_make_struct, scm_make_vtable_vtable),
+ struct.h (scm_struct_free_t, scm_alloc_struct, scm_struct_free_0,
+ scm_struct_free_light, scm_struct_free_standard,
+ scm_struct_free_entity): Struct data regions (and thus also
+ vtable data regions) are now C arrays of scm_bits_t elements.
+
+ * gc.c (scm_gc_mark, scm_gc_sweep, scm_unhash_name): Made the
+ mixup of glocs and structs explicit.
+
+ * gc.c (scm_unprotect_object): Compare SCM's with SCM_EQ_P.
+
+2000-04-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
* eval.c (scm_unmemocar): Use macros to test for gloc cell.
Minimize scope of variable 'ir'.
diff --git a/libguile/gc.c b/libguile/gc.c
index 9ff841aab..d2dc4adcb 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1128,55 +1128,61 @@ gc_mark_nimp:
break;
SCM_SETGCMARK (ptr);
{
- SCM vcell;
- vcell = (SCM) SCM_STRUCT_VTABLE_DATA (ptr);
- switch (SCM_UNPACK (SCM_CDR (vcell)))
+ /* Dirk:FIXME:: The following code is super ugly: ptr may be a struct
+ * or a gloc. If it is a gloc, the cell word #0 of ptr is a pointer
+ * to a heap cell. If it is a struct, the cell word #0 of ptr is a
+ * pointer to a struct vtable data region. The fact that these are
+ * accessed in the same way restricts the possibilites to change the
+ * data layout of structs or heap cells.
+ */
+ scm_bits_t word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc;
+ scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */
+ switch (vtable_data [scm_vtable_index_vcell])
{
default:
- scm_gc_mark (vcell);
- ptr = SCM_GCCDR (ptr);
- goto gc_mark_loop;
+ {
+ /* ptr is a gloc */
+ SCM gloc_car = SCM_PACK (word0);
+ scm_gc_mark (gloc_car);
+ ptr = SCM_GCCDR (ptr);
+ goto gc_mark_loop;
+ }
case 1: /* ! */
case 0: /* ! */
{
- SCM layout;
- SCM * vtable_data;
- int len;
- char * fields_desc;
- register SCM * mem;
- register int x;
-
- vtable_data = (SCM *) vcell;
- layout = vtable_data[scm_vtable_index_layout];
- len = SCM_LENGTH (layout);
- fields_desc = SCM_CHARS (layout);
+ /* ptr is a struct */
+ SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
+ int len = SCM_LENGTH (layout);
+ char * fields_desc = SCM_CHARS (layout);
/* We're using SCM_GCCDR here like STRUCT_DATA, except
that it removes the mark */
- mem = (SCM *) SCM_GCCDR (ptr);
+ scm_bits_t * struct_data = (scm_bits_t *) SCM_UNPACK (SCM_GCCDR (ptr));
- if (SCM_UNPACK (vtable_data[scm_struct_i_flags]) & SCM_STRUCTF_ENTITY)
+ if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
{
- scm_gc_mark (mem[scm_struct_i_procedure]);
- scm_gc_mark (mem[scm_struct_i_setter]);
+ scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure]));
+ scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter]));
}
if (len)
{
- for (x = 0; x < len - 2; x += 2, ++mem)
+ int x;
+
+ for (x = 0; x < len - 2; x += 2, ++struct_data)
if (fields_desc[x] == 'p')
- scm_gc_mark (*mem);
+ scm_gc_mark (SCM_PACK (*struct_data));
if (fields_desc[x] == 'p')
{
if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
- for (x = (long int) *mem; x; --x)
- scm_gc_mark (*++mem);
+ for (x = *struct_data; x; --x)
+ scm_gc_mark (SCM_PACK (*++struct_data));
else
- scm_gc_mark (*mem);
+ scm_gc_mark (SCM_PACK (*struct_data));
}
}
- if (!SCM_CDR (vcell))
+ if (vtable_data [scm_vtable_index_vcell] == 0)
{
- SCM_SETGCMARK (vcell);
- ptr = vtable_data[scm_vtable_index_vtable];
+ vtable_data [scm_vtable_index_vcell] = 1;
+ ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
goto gc_mark_loop;
}
}
@@ -1637,24 +1643,28 @@ scm_gc_sweep ()
switch SCM_TYP7 (scmptr)
{
case scm_tcs_cons_gloc:
- if (SCM_GCMARKP (scmptr))
- {
- if (SCM_CELL_WORD_1 ((SCM) SCM_STRUCT_VTABLE_DATA (scmptr))
- == 1)
- SCM_SET_CELL_WORD_1 ((SCM) SCM_STRUCT_VTABLE_DATA (scmptr),
- 0);
- goto cmrkcontinue;
- }
{
- SCM vcell;
- vcell = (SCM) SCM_STRUCT_VTABLE_DATA (scmptr);
-
- if ((SCM_CELL_WORD_1 (vcell) == 0)
- || (SCM_CELL_WORD_1 (vcell) == 1))
+ /* Dirk:FIXME:: Again, super ugly code: scmptr may be a
+ * struct or a gloc. See the corresponding comment in
+ * scm_gc_mark.
+ */
+ scm_bits_t word0 = SCM_CELL_WORD_0 (scmptr) - scm_tc3_cons_gloc;
+ scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */
+ if (SCM_GCMARKP (scmptr))
{
- scm_struct_free_t free
- = (scm_struct_free_t) ((SCM*) vcell)[scm_struct_i_free];
- m += free ((SCM *) vcell, (SCM *) SCM_GCCDR (scmptr));
+ if (vtable_data [scm_vtable_index_vcell] == 1)
+ vtable_data [scm_vtable_index_vcell] = 0;
+ goto cmrkcontinue;
+ }
+ else
+ {
+ if (vtable_data [scm_vtable_index_vcell] == 0
+ || vtable_data [scm_vtable_index_vcell] == 1)
+ {
+ scm_struct_free_t free
+ = (scm_struct_free_t) vtable_data[scm_struct_i_free];
+ m += free (vtable_data, (scm_bits_t *) SCM_UNPACK (SCM_GCCDR (scmptr)));
+ }
}
}
break;
@@ -1813,7 +1823,7 @@ scm_gc_sweep ()
k = SCM_SMOBNUM (scmptr);
if (!(k < scm_numsmob))
goto sweeperr;
- m += (scm_smobs[k].free) ((SCM) scmptr);
+ m += (scm_smobs[k].free) (scmptr);
break;
}
}
@@ -2401,7 +2411,6 @@ alloc_some_heap (scm_freelist_t *freelist)
}
-
SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0,
(SCM name),
"")
@@ -2420,16 +2429,19 @@ SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0,
pbound = (SCM_CELLPTR)scm_heap_table[x].bounds[1];
while (p < pbound)
{
- SCM incar;
- incar = p->car;
- if (1 == (7 & (int)incar))
+ SCM cell = PTR2SCM (p);
+ if (SCM_TYP3 (cell) == scm_tc3_cons_gloc)
{
- --incar;
- if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name))
- && (SCM_CDR (incar) != 0)
- && (SCM_UNPACK (SCM_CDR (incar)) != 1))
+ /* Dirk:FIXME:: Again, super ugly code: cell may be a gloc or a
+ * struct cell. See the corresponding comment in scm_gc_mark.
+ */
+ scm_bits_t word0 = SCM_CELL_WORD_0 (cell) - scm_tc3_cons_gloc;
+ SCM gloc_car = SCM_PACK (word0); /* access as gloc */
+ SCM vcell = SCM_CELL_OBJECT_1 (gloc_car);
+ if ((SCM_TRUE_P (name) || SCM_EQ_P (SCM_CAR (gloc_car), name))
+ && (SCM_UNPACK (vcell) != 0) && (SCM_UNPACK (vcell) != 1))
{
- p->car = name;
+ SCM_SET_CELL_OBJECT_0 (cell, name);
}
}
++p;
@@ -2517,7 +2529,7 @@ scm_unprotect_object (SCM obj)
SCM *tail_ptr = &scm_protects;
while (SCM_CONSP (*tail_ptr))
- if (SCM_CAR (*tail_ptr) == obj)
+ if (SCM_EQ_P (SCM_CAR (*tail_ptr), obj))
{
*tail_ptr = SCM_CDR (*tail_ptr);
break;
diff --git a/libguile/struct.c b/libguile/struct.c
index b4482719b..6e55635ac 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -305,54 +305,54 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
Ugh. */
-SCM *
+scm_bits_t *
scm_alloc_struct (int n_words, int n_extra, char *who)
{
- int size = sizeof (SCM) * (n_words + n_extra) + 7;
- SCM *block = (SCM *) scm_must_malloc (size, who);
+ int size = sizeof (scm_bits_t) * (n_words + n_extra) + 7;
+ void * block = scm_must_malloc (size, who);
/* Adjust the pointer to hide the extra words. */
- SCM *p = block + n_extra;
+ scm_bits_t * p = (scm_bits_t *) block + n_extra;
/* Adjust it even further so it's aligned on an eight-byte boundary. */
- p = (SCM *) (((scm_bits_t) SCM_UNPACK (p) + 7) & ~7);
+ p = (scm_bits_t *) (((scm_bits_t) p + 7) & ~7);
/* Initialize a few fields as described above. */
- p[scm_struct_i_free] = (SCM) scm_struct_free_standard;
- p[scm_struct_i_ptr] = (SCM) block;
- p[scm_struct_i_n_words] = (SCM) n_words;
+ p[scm_struct_i_free] = (scm_bits_t) scm_struct_free_standard;
+ p[scm_struct_i_ptr] = (scm_bits_t) block;
+ p[scm_struct_i_n_words] = n_words;
p[scm_struct_i_flags] = 0;
return p;
}
scm_sizet
-scm_struct_free_0 (SCM *vtable, SCM *data)
+scm_struct_free_0 (scm_bits_t * vtable, scm_bits_t * data)
{
return 0;
}
scm_sizet
-scm_struct_free_light (SCM *vtable, SCM *data)
+scm_struct_free_light (scm_bits_t * vtable, scm_bits_t * data)
{
free (data);
- return SCM_UNPACK (vtable[scm_struct_i_size]) & ~SCM_STRUCTF_MASK;
+ return vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK;
}
scm_sizet
-scm_struct_free_standard (SCM *vtable, SCM *data)
+scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data)
{
- size_t n = ((SCM_UNPACK (data[scm_struct_i_n_words]) + scm_struct_n_extra_words)
- * sizeof (SCM) + 7);
+ size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words)
+ * sizeof (scm_bits_t) + 7;
free ((void *) data[scm_struct_i_ptr]);
return n;
}
scm_sizet
-scm_struct_free_entity (SCM *vtable, SCM *data)
+scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data)
{
- size_t n = (SCM_UNPACK(data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
- * sizeof (SCM) + 7);
+ size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
+ * sizeof (scm_bits_t) + 7;
free ((void *) data[scm_struct_i_ptr]);
return n;
}
@@ -374,7 +374,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
SCM layout;
int basic_size;
int tail_elts;
- SCM * data;
+ scm_bits_t * data;
SCM handle;
SCM_VALIDATE_VTABLE (1,vtable);
@@ -390,15 +390,15 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
data = scm_alloc_struct (basic_size + tail_elts,
scm_struct_entity_n_extra_words,
"make-struct");
- data[scm_struct_i_procedure] = SCM_BOOL_F;
- data[scm_struct_i_setter] = SCM_BOOL_F;
+ data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F);
+ data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F);
}
else
data = scm_alloc_struct (basic_size + tail_elts,
scm_struct_n_extra_words,
"make-struct");
SCM_SET_CELL_WORD_1 (handle, data);
- SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
+ SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) SCM_STRUCT_DATA (vtable) + scm_tc3_cons_gloc);
scm_struct_init (handle, tail_elts, init);
SCM_ALLOW_INTS;
return handle;
@@ -469,7 +469,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
SCM layout;
int basic_size;
int tail_elts;
- SCM * data;
+ scm_bits_t * data;
SCM handle;
SCM_VALIDATE_ROSTRING (1,extra_fields);
@@ -487,7 +487,7 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
scm_struct_n_extra_words,
"make-vtable-vtable");
SCM_SET_CELL_WORD_1 (handle, data);
- SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
+ SCM_SET_CELL_WORD_0 (handle, (scm_bits_t) data + scm_tc3_cons_gloc);
SCM_SET_STRUCT_LAYOUT (handle, layout);
scm_struct_init (handle, tail_elts, scm_cons (layout, init));
SCM_ALLOW_INTS;
diff --git a/libguile/struct.h b/libguile/struct.h
index 1e81acd29..a2c3edbfb 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -70,16 +70,17 @@
#define scm_vtable_index_printer 3 /* A printer for this struct type. */
#define scm_vtable_offset_user 4 /* Where do user fields start? */
-typedef scm_sizet (*scm_struct_free_t) (SCM *vtable, SCM *data);
+typedef scm_sizet (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data);
#define SCM_STRUCTF_MASK (0xFFF << 20)
#define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */
#define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation
(no hidden words) */
+/* Dirk:FIXME:: the SCM_STRUCTP predicate is also fulfilled for glocs */
#define SCM_STRUCTP(X) (SCM_NIMP(X) && (SCM_TYP3(X) == scm_tc3_cons_gloc))
#define SCM_STRUCT_DATA(X) ((scm_bits_t *) SCM_CELL_WORD_1 (X))
-#define SCM_STRUCT_VTABLE_DATA(X) ((scm_bits_t *) (SCM_CELL_WORD_0 (X) - 1))
+#define SCM_STRUCT_VTABLE_DATA(X) ((scm_bits_t *) (SCM_CELL_WORD_0 (X) - scm_tc3_cons_gloc))
#define SCM_STRUCT_LAYOUT(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout]))
#define SCM_SET_STRUCT_LAYOUT(X, v) (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout] = SCM_UNPACK (v))
@@ -98,13 +99,11 @@ extern SCM scm_struct_table;
-extern SCM *scm_alloc_struct (int n_words,
- int n_extra,
- char *who);
-extern scm_sizet scm_struct_free_0 (SCM *vtable, SCM *data);
-extern scm_sizet scm_struct_free_light (SCM *vtable, SCM *data);
-extern scm_sizet scm_struct_free_standard (SCM *vtable, SCM *data);
-extern scm_sizet scm_struct_free_entity (SCM *vtable, SCM *data);
+extern scm_bits_t * scm_alloc_struct (int n_words, int n_extra, char * who);
+extern scm_sizet scm_struct_free_0 (scm_bits_t * vtable, scm_bits_t * data);
+extern scm_sizet scm_struct_free_light (scm_bits_t * vtable, scm_bits_t * data);
+extern scm_sizet scm_struct_free_standard (scm_bits_t * vtable, scm_bits_t * data);
+extern scm_sizet scm_struct_free_entity (scm_bits_t * vtable, scm_bits_t * data);
extern void scm_struct_init (SCM handle, int tail_elts, SCM inits);
extern SCM scm_make_struct_layout (SCM fields);
extern SCM scm_struct_p (SCM x);