mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +02:00
Code Activity

New dump/undump scheme.

Browse source
This commit is contained in:
Keisuke Nishida 2001-02-05 08:46:21 +00:00
parent 93a6e9c4a7
commit 914cceec2c
6 changed files with 312 additions and 415 deletions
Download patch file Download diff file Expand all files Collapse all files

16
libguile/ChangeLog
View file

@ -1,3 +1,19 @@
2001-02-05 Keisuke Nishida <kxn30@po.cwru.edu>
* dump.c, dump.h: Modified a lot.
(scm_dump_mark): Removed.
(scm_restore_cell_object, scm_store_cell_object): New functions.
* smob.h (scm_smob_descriptor): Removed slots: dump_mark,
dump_dealloc, dump_store, undump_alloc, undump_restore, undump_init.
New slots: dump, undump.
* smob.c (scm_make_smob_type, scm_set_smob_dump, scm_set_smob_undump):
Updated.
* keywords.c (keyword_dump): Renamed from keyword_dealloc.
(keyword_undump): Renamed from keyword_alloc.
(scm_init_keywords): Set keyword_dump and keyword_undump.
2001-02-03 Michael Livshin <mlivshin@bigfoot.com> 2001-02-03 Michael Livshin <mlivshin@bigfoot.com>
* gc.c (DOUBLECELL_ALIGNED_P): new macro, a better-named analog of * gc.c (DOUBLECELL_ALIGNED_P): new macro, a better-named analog of

642
libguile/dump.c
View file

@ -62,22 +62,30 @@
#define SCM_DUMP_COOKIE "\x7fGBF-0.0" #define SCM_DUMP_COOKIE "\x7fGBF-0.0"
#define SCM_DUMP_INITIAL_HASH_SIZE 511 #define SCM_DUMP_HASH_SIZE 151
#define SCM_DUMP_INITIAL_IMAGE_SIZE 4096 #define SCM_DUMP_IMAGE_SIZE 4096
#define SCM_DUMP_INDEX_TO_WORD(x) ((scm_bits_t) ((x) << 3)) #define SCM_DUMP_INDEX_TO_WORD(x) ((scm_bits_t) ((x) << 3))
#define SCM_DUMP_WORD_TO_INDEX(x) ((long) ((x) >> 3)) #define SCM_DUMP_WORD_TO_INDEX(x) ((long) ((x) >> 3))
struct scm_dump_header { struct scm_dump_header {
scm_bits_t cookie; /* cookie string */ scm_bits_t cookie; /* cookie string */
scm_bits_t version; /* version string */ scm_bits_t version; /* version string */
scm_bits_t nmeta; /* the number of meta data */ scm_bits_t nobjs; /* the number of objects */
scm_bits_t init; /* initial object indicator */ /* or immediate value */
}; };
struct scm_dump_meta { struct scm_dump_object_update {
scm_bits_t tc; /* the type of objects */ scm_bits_t id; /* object identifier */
scm_bits_t nobjs; /* the number of objects */ scm_bits_t *addr; /* object address */
struct scm_dump_object_update *next; /* next update */
};
struct scm_dump_cell_update {
scm_bits_t id; /* object identifier */
SCM cell; /* cell */
int n; /* 0-3 */
struct scm_dump_cell_update *next; /* next update */
}; };
@ -88,29 +96,41 @@ struct scm_dump_meta {
static scm_bits_t scm_tc16_dstate; static scm_bits_t scm_tc16_dstate;
struct scm_dstate { struct scm_dstate {
/* Memory image */
int mmapped; int mmapped;
scm_sizet image_size; scm_sizet image_size;
int image_index; int image_index;
char *image_base; /* memory image */ char *image_base;
SCM table; /* object table */
/* Object table */
int table_index;
SCM table;
/* Update schedule */
struct scm_dump_object_update *object_updates;
struct scm_dump_cell_update *cell_updates;
}; };
#define SCM_DSTATE_DATA(d) ((struct scm_dstate *) SCM_SMOB_DATA (d)) #define SCM_DSTATE_DATA(d) ((struct scm_dstate *) SCM_SMOB_DATA (d))
#define SCM_DSTATE_TABLE(d) (SCM_DSTATE_DATA (d)->table)
#define SCM_DSTATE_TABLE(d) (SCM_DSTATE_DATA (d)->table) #define SCM_DSTATE_TABLE_REF(d,i) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i])
#define SCM_DSTATE_TABLE_LENGTH(d) SCM_VECTOR_LENGTH (SCM_DSTATE_TABLE (d)) #define SCM_DSTATE_TABLE_SET(d,i,x) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i] = (x))
#define SCM_DSTATE_TABLE_BASE(d) SCM_VELTS (SCM_DSTATE_TABLE (d)) #define SCM_DSTATE_OBJECT_UPDATES(d)(SCM_DSTATE_DATA (d)->object_updates)
#define SCM_DSTATE_CELL_UPDATES(d) (SCM_DSTATE_DATA (d)->cell_updates)
static SCM static SCM
make_dstate () make_dstate ()
#define FUNC_NAME "make_dstate" #define FUNC_NAME "make_dstate"
{ {
struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate)); struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate));
p->mmapped = 0; p->mmapped = 0;
p->image_size = SCM_DUMP_INITIAL_IMAGE_SIZE; p->image_size = SCM_DUMP_IMAGE_SIZE;
p->image_index = 0; p->image_index = 0;
p->image_base = SCM_MUST_MALLOC (p->image_size); p->image_base = SCM_MUST_MALLOC (p->image_size);
p->table = SCM_BOOL_F; p->table_index = 0;
p->table = SCM_BOOL_F;
p->object_updates = 0;
p->cell_updates = 0;
SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); SCM_RETURN_NEWSMOB (scm_tc16_dstate, p);
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -132,11 +152,14 @@ make_dstate_by_mmap (int fd)
if (addr == MAP_FAILED) if (addr == MAP_FAILED)
SCM_SYSERROR; SCM_SYSERROR;
p->mmapped = 1; p->mmapped = 1;
p->image_size = st.st_size; p->image_size = st.st_size;
p->image_index = 0; p->image_index = 0;
p->image_base = addr; p->image_base = addr;
p->table = SCM_BOOL_F; p->table_index = 0;
p->table = SCM_BOOL_F;
p->object_updates = 0;
p->cell_updates = 0;
SCM_RETURN_NEWSMOB (scm_tc16_dstate, p); SCM_RETURN_NEWSMOB (scm_tc16_dstate, p);
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -153,6 +176,8 @@ dstate_free (SCM obj)
{ {
int size = sizeof (struct scm_dstate); int size = sizeof (struct scm_dstate);
struct scm_dstate *p = SCM_DSTATE_DATA (obj); struct scm_dstate *p = SCM_DSTATE_DATA (obj);
/* Free dump image */
if (p->mmapped) if (p->mmapped)
{ {
int rv; int rv;
@ -166,6 +191,23 @@ dstate_free (SCM obj)
if (p->image_base) if (p->image_base)
scm_must_free (p->image_base); scm_must_free (p->image_base);
} }
/* Free update schedules */
while (p->object_updates)
{
struct scm_dump_object_update *next = p->object_updates->next;
scm_must_free (p->object_updates);
size += sizeof (struct scm_dump_object_update);
p->object_updates = next;
}
while (p->cell_updates)
{
struct scm_dump_cell_update *next = p->cell_updates->next;
scm_must_free (p->cell_updates);
size += sizeof (struct scm_dump_cell_update);
p->cell_updates = next;
}
scm_must_free (p); scm_must_free (p);
return size; return size;
} }
@ -191,19 +233,17 @@ static scm_bits_t
scm_object_indicator (SCM obj, SCM dstate) scm_object_indicator (SCM obj, SCM dstate)
{ {
if (SCM_IMP (obj)) if (SCM_IMP (obj))
return SCM_UNPACK (obj); {
return SCM_UNPACK (obj);
}
else else
{ {
int i; SCM id = scm_hashq_ref (SCM_DSTATE_TABLE (dstate), obj, SCM_BOOL_F);
int len = SCM_DSTATE_TABLE_LENGTH (dstate); if (SCM_FALSEP (id))
SCM *base = SCM_DSTATE_TABLE_BASE (dstate); return -1;
for (i = 0; i < len; i++) else
if (SCM_EQ_P (obj, base[i])) return SCM_DUMP_INDEX_TO_WORD (SCM_INUM (id));
return SCM_DUMP_INDEX_TO_WORD (i);
} }
scm_misc_error ("scm_object_indicator",
"Non-marked object: ~A", SCM_LIST1 (obj));
return 0;
} }
static SCM static SCM
@ -212,7 +252,7 @@ scm_indicator_object (scm_bits_t word, SCM dstate)
if (SCM_IMP (SCM_PACK (word))) if (SCM_IMP (SCM_PACK (word)))
return SCM_PACK (word); return SCM_PACK (word);
else else
return SCM_DSTATE_TABLE_BASE (dstate)[SCM_DUMP_WORD_TO_INDEX (word)]; return SCM_DSTATE_TABLE_REF (dstate, SCM_DUMP_WORD_TO_INDEX (word));
} }
@ -220,6 +260,8 @@ scm_indicator_object (scm_bits_t word, SCM dstate)
* Dump interface * Dump interface
*/ */
/* store functions */
static void static void
scm_store_pad (SCM dstate) scm_store_pad (SCM dstate)
{ {
@ -230,21 +272,15 @@ scm_store_pad (SCM dstate)
p->image_base[p->image_index++] = '\0'; p->image_base[p->image_index++] = '\0';
} }
static void void
scm_store_chars (const char *addr, scm_sizet size, SCM dstate) scm_store_string (const char *addr, scm_sizet size, SCM dstate)
{ {
struct scm_dstate *p = SCM_DSTATE_DATA (dstate); struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
while (p->image_index + size >= p->image_size) while (p->image_index + size + 1 >= p->image_size)
dstate_extend (p); dstate_extend (p);
memcpy (p->image_base + p->image_index, addr, size); memcpy (p->image_base + p->image_index, addr, size);
memcpy (p->image_base + p->image_index + size, "\0", 1); memcpy (p->image_base + p->image_index + size, "\0", 1);
p->image_index += size + 1; p->image_index += size + 1;
}
void
scm_store_string (const char *addr, scm_sizet size, SCM dstate)
{
scm_store_chars (addr, size, dstate);
scm_store_pad (dstate); scm_store_pad (dstate);
} }
@ -268,9 +304,30 @@ scm_store_word (const scm_bits_t word, SCM dstate)
void void
scm_store_object (SCM obj, SCM dstate) scm_store_object (SCM obj, SCM dstate)
{ {
scm_store_word (scm_object_indicator (obj, dstate), dstate); scm_bits_t id = scm_object_indicator (obj, dstate);
if (id == -1)
{
/* OBJ is not stored yet. Do it later */
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
struct scm_dump_object_update *update =
scm_must_malloc (sizeof (struct scm_dump_object_update),
"scm_store_object");
update->id = SCM_UNPACK (obj);
update->addr = (scm_bits_t *) p->image_index;
update->next = p->object_updates;
p->object_updates = update;
}
scm_store_word (id, dstate);
} }
void
scm_store_cell_object (SCM cell, int n, SCM dstate)
{
scm_store_object (SCM_CELL_OBJECT (cell, n), dstate);
}
/* restore functions */
static void static void
scm_restore_pad (SCM dstate) scm_restore_pad (SCM dstate)
{ {
@ -279,20 +336,13 @@ scm_restore_pad (SCM dstate)
p->image_index++; p->image_index++;
} }
static const char * const char *
scm_restore_chars (SCM dstate, int *lenp) scm_restore_string (SCM dstate, int *lenp)
{ {
struct scm_dstate *p = SCM_DSTATE_DATA (dstate); struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
const char *addr = p->image_base + p->image_index; const char *addr = p->image_base + p->image_index;
*lenp = strlen (addr); *lenp = strlen (addr);
p->image_index += *lenp + 1; p->image_index += *lenp + 1;
return addr;
}
const char *
scm_restore_string (SCM dstate, int *lenp)
{
const char *addr = scm_restore_chars (dstate, lenp);
scm_restore_pad (dstate); scm_restore_pad (dstate);
return addr; return addr;
} }
@ -316,10 +366,42 @@ scm_restore_word (SCM dstate)
return word; return word;
} }
SCM void
scm_restore_object (SCM dstate) scm_restore_object (SCM *objp, SCM dstate)
{ {
return scm_indicator_object (scm_restore_word (dstate), dstate); scm_bits_t id = scm_restore_word (dstate);
*objp = scm_indicator_object (id, dstate);
if (SCM_UNBNDP (*objp))
{
struct scm_dump_object_update *update =
scm_must_malloc (sizeof (struct scm_dump_object_update),
"scm_restore_object");
update->id = id;
update->addr = (scm_bits_t *) objp;
update->next = SCM_DSTATE_OBJECT_UPDATES (dstate);
SCM_DSTATE_OBJECT_UPDATES (dstate) = update;
}
}
void
scm_restore_cell_object (SCM cell, int n, SCM dstate)
{
scm_bits_t id = scm_restore_word (dstate);
SCM obj = scm_indicator_object (id, dstate);
SCM_SET_CELL_OBJECT (cell, n, obj);
if (SCM_UNBNDP (obj))
{
struct scm_dump_cell_update *update =
scm_must_malloc (sizeof (struct scm_dump_cell_update),
"scm_restore_cell_object");
update->id = id;
update->cell = cell;
update->n = n;
update->next = SCM_DSTATE_CELL_UPDATES (dstate);
SCM_DSTATE_CELL_UPDATES (dstate) = update;
}
} }
@ -327,275 +409,145 @@ scm_restore_object (SCM dstate)
* Dump routine * Dump routine
*/ */
void static void
scm_dump_mark (SCM obj, SCM dstate) scm_dump (SCM obj, SCM dstate)
{ {
SCM table = SCM_DSTATE_TABLE (dstate); struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
loop: /* Check if immediate or already dumpped */
/* Nothing with immediates */ if (scm_object_indicator (obj, dstate) != -1)
if (SCM_IMP (obj))
return; return;
/* Return if already marked */ /* Mark it */
if (!SCM_FALSEP (scm_hashq_ref (table, obj, SCM_BOOL_F))) scm_hashq_set_x (p->table, obj, SCM_MAKINUM (p->table_index));
return; p->table_index++;
if (SCM_SLOPPY_CONSP (obj)) if (SCM_SLOPPY_CONSP (obj))
{ {
scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc3_cons)); scm_store_word (scm_tc3_cons, dstate);
scm_dump_mark (SCM_CAR (obj), dstate); /* Store cdr first in order to avoid a possible deep recursion
obj = SCM_CDR (obj); * with a long list */
goto loop; scm_store_cell_object (obj, 1, dstate);
scm_store_cell_object (obj, 0, dstate);
goto next_dump;
} }
switch (SCM_TYP7 (obj)) switch (SCM_TYP7 (obj))
{ {
case scm_tc7_symbol: case scm_tc7_symbol:
scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_symbol)); {
return; scm_store_word (scm_tc7_symbol, dstate);
scm_store_string (SCM_SYMBOL_CHARS (obj),
SCM_SYMBOL_LENGTH (obj),
dstate);
return;
}
case scm_tc7_substring: case scm_tc7_substring:
case scm_tc7_string: case scm_tc7_string:
scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_string)); {
return; scm_store_word (scm_tc7_string, dstate);
scm_store_string (SCM_STRING_CHARS (obj),
SCM_STRING_LENGTH (obj),
dstate);
return;
}
case scm_tc7_vector: case scm_tc7_vector:
{ {
int i; int i;
int len = SCM_VECTOR_LENGTH (obj); int len = SCM_VECTOR_LENGTH (obj);
SCM *base = SCM_VELTS (obj); SCM *base = SCM_VELTS (obj);
scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_vector)); scm_store_word (scm_tc7_vector, dstate);
scm_store_word (len, dstate);
for (i = 0; i < len; i++) for (i = 0; i < len; i++)
scm_dump_mark (base[i], dstate); scm_store_object (base[i], dstate);
return; goto next_dump;
} }
case scm_tc7_smob: case scm_tc7_smob:
{ {
SCM (*mark) () = SCM_SMOB_DESCRIPTOR (obj).dump_mark; void (*dump) () = SCM_SMOB_DESCRIPTOR (obj).dump;
void (*dealloc) () = SCM_SMOB_DESCRIPTOR (obj).dump_dealloc; if (!dump)
void (*store) () = SCM_SMOB_DESCRIPTOR (obj).dump_store; goto error;
if (!(mark || dealloc || store)) /* FIXME: SCM_CELL_TYPE may change when undump!! */
break; scm_store_word (SCM_CELL_TYPE (obj), dstate);
dump (obj, dstate);
scm_hashq_set_x (table, obj, SCM_MAKINUM (SCM_CELL_TYPE (obj))); goto next_dump;
if (mark)
{
obj = mark (obj, dstate);
goto loop;
}
return;
} }
default:
error:
scm_misc_error ("scm_dump_mark", "Cannot dump: ~A", SCM_LIST1 (obj));
} }
scm_misc_error ("scm_dump_mark", "Cannot dump: ~A", SCM_LIST1 (obj));
}
static void next_dump:
scm_dump_dealloc (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) while (p->object_updates)
{
switch (SCM_ITAG7 (SCM_PACK (tc)))
{ {
case scm_tc7_symbol: struct scm_dump_object_update *update = p->object_updates;
{ p->object_updates = update->next;
int i; scm_dump (SCM_PACK (update->id), dstate);
for (i = 0; i < nobjs; i++) *(scm_bits_t *) (p->image_base + (int) update->addr) =
{ scm_object_indicator (SCM_PACK (update->id), dstate);
SCM obj = table[i]; scm_must_free (update);
scm_store_chars (SCM_SYMBOL_CHARS (obj),
SCM_SYMBOL_LENGTH (obj),
dstate);
}
scm_store_pad (dstate);
return;
}
case scm_tc7_string:
{
int i;
for (i = 0; i < nobjs; i++)
{
SCM obj = table[i];
scm_store_chars (SCM_STRING_CHARS (obj),
SCM_STRING_LENGTH (obj),
dstate);
}
scm_store_pad (dstate);
return;
}
case scm_tc7_vector:
{
int i;
for (i = 0; i < nobjs; i++)
scm_store_word (SCM_VECTOR_LENGTH (table[i]), dstate);
return;
}
case scm_tc7_smob:
{
int i;
void (*dealloc) () = scm_smobs[SCM_TC2SMOBNUM(tc)].dump_dealloc;
if (dealloc)
for (i = 0; i < nobjs; i++)
dealloc (table[i], dstate);
return;
}
} }
} }
static void static void
scm_dump_store (scm_bits_t tc, int nobjs, SCM *table, SCM dstate) scm_undump (SCM dstate)
{ {
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
scm_bits_t tc = scm_restore_word (dstate);
SCM obj;
if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons) if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons)
{ {
int i; SCM_NEWCELL (obj);
for (i = 0; i < nobjs; i++) /* cdr was stored first */
{ scm_restore_cell_object (obj, 1, dstate);
SCM obj = table[i]; scm_restore_cell_object (obj, 0, dstate);
scm_store_object (SCM_CAR (obj), dstate); goto store_object;
scm_store_object (SCM_CDR (obj), dstate);
}
return;
}
switch (SCM_ITAG7 (SCM_PACK (tc)))
{
case scm_tc7_vector:
{
int i, j;
for (i = 0; i < nobjs; i++)
{
SCM obj = table[i];
int len = SCM_VECTOR_LENGTH (obj);
SCM *base = SCM_VELTS (obj);
for (j = 0; j < len; j++)
scm_store_object (base[j], dstate);
}
return;
}
case scm_tc7_smob:
{
int i;
void (*store) () = scm_smobs[SCM_TC2SMOBNUM(tc)].dump_store;
if (store)
for (i = 0; i < nobjs; i++)
store (table[i], dstate);
return;
}
}
}
static void
scm_undump_alloc (scm_bits_t tc, int nobjs, SCM *table, SCM dstate)
{
if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons)
{
int i;
for (i = 0; i < nobjs; i++)
SCM_NEWCELL (table[i]);
return;
} }
switch (SCM_ITAG7 (SCM_PACK (tc))) switch (SCM_ITAG7 (SCM_PACK (tc)))
{ {
case scm_tc7_symbol: case scm_tc7_symbol:
{ {
int i; int len;
for (i = 0; i < nobjs; i++) const char *mem = scm_restore_string (dstate, &len);
{ obj = scm_mem2symbol (mem, len);
int len; goto store_object;
const char *mem = scm_restore_chars (dstate, &len);
table[i] = scm_mem2symbol (mem, len);
}
scm_restore_pad (dstate);
return;
} }
case scm_tc7_string: case scm_tc7_string:
{ {
int i; int len;
for (i = 0; i < nobjs; i++) const char *mem = scm_restore_string (dstate, &len);
{ obj = scm_makfromstr (mem, len, 0);
int len; goto store_object;
const char *mem = scm_restore_chars (dstate, &len);
table[i] = scm_makfromstr (mem, len, 0);
}
scm_restore_pad (dstate);
return;
} }
case scm_tc7_vector: case scm_tc7_vector:
{ {
int i; int i;
for (i = 0; i < nobjs; i++) int len = scm_restore_word (dstate);
{ SCM *base;
int len = scm_restore_word (dstate); obj = scm_c_make_vector (len, SCM_BOOL_F);
table[i] = scm_c_make_vector (len, SCM_BOOL_F); base = SCM_VELTS (obj);
} for (i = 0; i < len; i++)
return; scm_restore_object (&base[i], dstate);
goto store_object;
} }
case scm_tc7_smob: case scm_tc7_smob:
{ {
int i; SCM (*undump) () = scm_smobs[SCM_TC2SMOBNUM (tc)].undump;
SCM (*alloc) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_alloc; if (!undump)
if (!alloc) goto error;
break; obj = undump (dstate);
for (i = 0; i < nobjs; i++) goto store_object;
table[i] = alloc (dstate);
return;
} }
} default:
scm_misc_error ("scm_undump_alloc", "Cannot undump", SCM_EOL); error:
} scm_misc_error ("scm_undump", "Cannot undump", SCM_EOL);
static void
scm_undump_restore (scm_bits_t tc, int nobjs, SCM *table, SCM dstate)
#define FUNC_NAME "scm_undump_restore"
{
if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons)
{
int i;
for (i = 0; i < nobjs; i++)
{
SCM obj = table[i];
SCM_SETCAR (obj, scm_restore_object (dstate));
SCM_SETCDR (obj, scm_restore_object (dstate));
}
return;
} }
switch (SCM_ITAG7 (SCM_PACK (tc))) store_object:
{ SCM_DSTATE_TABLE_SET (dstate, p->table_index, obj);
case scm_tc7_vector: p->table_index++;
{
int i, j;
for (i = 0; i < nobjs; i++)
{
SCM obj = table[i];
int len = SCM_VECTOR_LENGTH (obj);
SCM *base = SCM_VELTS (obj);
for (j = 0; j < len; j++)
base[j] = scm_restore_object (dstate);
}
return;
}
case scm_tc7_smob:
{
int i;
void (*restore) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_restore;
if (restore)
for (i = 0; i < nobjs; i++)
restore (table[i], dstate);
}
}
}
#undef FUNC_NAME
static void
scm_undump_init (scm_bits_t tc, int nobjs, SCM *table, SCM dstate)
{
if (SCM_ITAG7 (SCM_PACK (tc)) == scm_tc7_smob)
{
int i;
void (*init) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_init;
if (init)
for (i = 0; i < nobjs; i++)
init (table[i]);
}
} }
@ -603,39 +555,14 @@ scm_undump_init (scm_bits_t tc, int nobjs, SCM *table, SCM dstate)
* Scheme interface * Scheme interface
*/ */
#define DUMP_APPLY(f,nmeta,meta,table) \
{ \
int i; \
int len = 0; \
for (i = 0; i < nmeta; i++) \
{ \
f (meta[i].tc, meta[i].nobjs, table + len, dstate); \
len += meta[i].nobjs; \
} \
}
static SCM
scm_dump_table_fold (void *proc, SCM key, SCM data, SCM value)
{
SCM handle = scm_sloppy_assq (data, value);
if (SCM_CONSP (handle))
{
SCM_SETCDR (handle, scm_cons (key, SCM_CDR (handle)));
return value;
}
else
return scm_acons (data, SCM_LIST1 (key), value);
}
SCM_DEFINE (scm_binary_write, "binary-write", 1, 1, 0, SCM_DEFINE (scm_binary_write, "binary-write", 1, 1, 0,
(SCM obj, SCM port), (SCM obj, SCM port),
"Write OBJ to PORT in a binary format.") "Write OBJ to PORT in a binary format.")
#define FUNC_NAME s_scm_binary_write #define FUNC_NAME s_scm_binary_write
{ {
int i, index, len, nmeta; struct scm_dstate *p;
struct scm_dump_header header; struct scm_dump_header header;
struct scm_dump_meta *meta; SCM dstate;
SCM dstate, alist, list, *base;
/* Check port */ /* Check port */
if (SCM_UNBNDP (port)) if (SCM_UNBNDP (port))
@ -643,57 +570,21 @@ SCM_DEFINE (scm_binary_write, "binary-write", 1, 1, 0,
else else
SCM_VALIDATE_OUTPUT_PORT (2, port); SCM_VALIDATE_OUTPUT_PORT (2, port);
/* Mark objects */ /* Dump objects */
dstate = make_dstate (); dstate = make_dstate ();
SCM_DSTATE_TABLE (dstate) = p = SCM_DSTATE_DATA (dstate);
scm_c_make_hash_table (SCM_DUMP_INITIAL_HASH_SIZE); p->table = scm_c_make_hash_table (SCM_DUMP_HASH_SIZE);
scm_dump_mark (obj, dstate); scm_dump (obj, dstate);
/* Build meta information */ /* Write image */
alist = scm_internal_hash_fold (scm_dump_table_fold, 0, SCM_EOL,
SCM_DSTATE_TABLE (dstate));
nmeta = scm_ilength (alist);
meta = alloca (nmeta * sizeof (struct scm_dump_meta));
list = alist;
len = 0;
for (i = 0; i < nmeta; i++)
{
meta[i].tc = SCM_INUM (SCM_CAAR (list));
meta[i].nobjs = scm_ilength (SCM_CDAR (list));
len += meta[i].nobjs;
list = SCM_CDR (list);
}
/* Build object table */
SCM_DSTATE_TABLE (dstate) = scm_c_make_vector (len, SCM_BOOL_F);
base = SCM_DSTATE_TABLE_BASE (dstate);
index = 0;
for (i = 0; i < nmeta; i++)
{
SCM list;
for (list = SCM_CDAR (alist); !SCM_NULLP (list); list = SCM_CDR (list))
base[index++] = SCM_CAR (list);
alist = SCM_CDR (alist);
}
/* Dump */
DUMP_APPLY (scm_dump_dealloc, nmeta, meta, base);
DUMP_APPLY (scm_dump_store, nmeta, meta, base);
/* Write header */
header.cookie = ((scm_bits_t *) SCM_DUMP_COOKIE)[0]; header.cookie = ((scm_bits_t *) SCM_DUMP_COOKIE)[0];
header.version = ((scm_bits_t *) SCM_DUMP_COOKIE)[1]; header.version = ((scm_bits_t *) SCM_DUMP_COOKIE)[1];
header.nmeta = nmeta; header.nobjs = (p->table_index
header.init = scm_object_indicator (obj, dstate); ? SCM_DUMP_INDEX_TO_WORD (p->table_index)
: SCM_UNPACK (obj));
scm_lfwrite ((const char *) &header, sizeof (struct scm_dump_header), port); scm_lfwrite ((const char *) &header, sizeof (struct scm_dump_header), port);
if (p->image_index)
/* Write the rest */ scm_lfwrite (p->image_base, p->image_index, port);
scm_lfwrite ((const char *) meta,
nmeta * sizeof (struct scm_dump_meta),
port);
scm_lfwrite (SCM_DSTATE_DATA (dstate)->image_base,
SCM_DSTATE_DATA (dstate)->image_index,
port);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -704,11 +595,10 @@ SCM_DEFINE (scm_binary_read, "binary-read", 0, 1, 0,
"Read an object from PORT in a binary format.") "Read an object from PORT in a binary format.")
#define FUNC_NAME s_scm_binary_read #define FUNC_NAME s_scm_binary_read
{ {
int i, len; int i, nobjs;
scm_bits_t *data; struct scm_dstate *p;
struct scm_dump_header *header; struct scm_dump_header *header;
struct scm_dump_meta *meta; SCM dstate;
SCM dstate, *base;
/* Check port */ /* Check port */
if (SCM_UNBNDP (port)) if (SCM_UNBNDP (port))
@ -723,37 +613,53 @@ SCM_DEFINE (scm_binary_read, "binary-read", 0, 1, 0,
else else
/* Undump with malloc */ /* Undump with malloc */
SCM_MISC_ERROR ("Not supported yet", SCM_EOL); SCM_MISC_ERROR ("Not supported yet", SCM_EOL);
p = SCM_DSTATE_DATA (dstate);
/* Read header */ /* Read header */
header = (struct scm_dump_header *) SCM_DSTATE_DATA (dstate)->image_base; header = (struct scm_dump_header *) p->image_base;
if (SCM_DSTATE_DATA (dstate)->image_size < sizeof (*header)) p->image_index += sizeof (struct scm_dump_header);
if (p->image_size < sizeof (*header))
SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port)); SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port));
if (header->cookie != ((scm_bits_t *) SCM_DUMP_COOKIE)[0]) if (header->cookie != ((scm_bits_t *) SCM_DUMP_COOKIE)[0])
SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port)); SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port));
if (header->version != ((scm_bits_t *) SCM_DUMP_COOKIE)[1]) if (header->version != ((scm_bits_t *) SCM_DUMP_COOKIE)[1])
SCM_MISC_ERROR ("Unsupported binary version: ~A", SCM_LIST1 (port)); SCM_MISC_ERROR ("Unsupported binary version: ~A", SCM_LIST1 (port));
/* Read the rest */ /* Check for immediate */
meta = (struct scm_dump_meta *) ((char *) header + sizeof (*header)); if (SCM_IMP (SCM_PACK (header->nobjs)))
data = (scm_bits_t *) (meta + header->nmeta); return SCM_PACK (header->nobjs);
SCM_DSTATE_DATA (dstate)->image_index = (char *) data - (char *) header;
/* Create object table */ /* Create object table */
len = 0; nobjs = SCM_DUMP_WORD_TO_INDEX (header->nobjs);
for (i = 0; i < header->nmeta; i++) p->table = scm_c_make_vector (nobjs, SCM_UNDEFINED);
len += meta[i].nobjs;
SCM_DSTATE_TABLE (dstate) = scm_c_make_vector (len, SCM_BOOL_F);
base = SCM_DSTATE_TABLE_BASE (dstate);
/* Undump */ /* Undump */
DUMP_APPLY (scm_undump_alloc, header->nmeta, meta, base); for (i = 0; i < nobjs; i++)
DUMP_APPLY (scm_undump_restore, header->nmeta, meta, base); scm_undump (dstate);
DUMP_APPLY (scm_undump_init, header->nmeta, meta, base);
/* Update references */
while (p->object_updates)
{
struct scm_dump_object_update *update = p->object_updates;
p->object_updates = update->next;
*(update->addr) = SCM_UNPACK (scm_indicator_object (update->id, dstate));
scm_must_free (update);
}
/* Link objects */
while (p->cell_updates)
{
struct scm_dump_cell_update *update = p->cell_updates;
p->cell_updates = update->next;
SCM_SET_CELL_OBJECT (update->cell,
update->n,
scm_indicator_object (update->id, dstate));
scm_must_free (update);
}
/* Return */ /* Return */
{ {
SCM obj = scm_indicator_object (header->init, dstate); SCM obj = SCM_DSTATE_TABLE_REF (dstate, 0);
SCM_DSTATE_TABLE (dstate) = SCM_BOOL_F; p->table = SCM_BOOL_F;
return obj; return obj;
} }
} }

6
libguile/dump.h
View file

@ -45,15 +45,17 @@
#include "libguile/__scm.h" #include "libguile/__scm.h"
extern void scm_dump_mark (SCM obj, SCM dstate);
extern void scm_store_string (const char *addr, scm_sizet size, SCM dstate); extern void scm_store_string (const char *addr, scm_sizet size, SCM dstate);
extern void scm_store_bytes (const char *addr, scm_sizet size, SCM dstate); extern void scm_store_bytes (const char *addr, scm_sizet size, SCM dstate);
extern void scm_store_word (const scm_bits_t word, SCM dstate); extern void scm_store_word (const scm_bits_t word, SCM dstate);
extern void scm_store_object (SCM obj, SCM dstate); extern void scm_store_object (SCM obj, SCM dstate);
extern void scm_store_cell_object (SCM cell, int n, SCM dstate);
extern const char *scm_restore_string (SCM dstate, int *lenp); extern const char *scm_restore_string (SCM dstate, int *lenp);
extern const char *scm_restore_bytes (SCM dstate, scm_sizet size); extern const char *scm_restore_bytes (SCM dstate, scm_sizet size);
extern scm_bits_t scm_restore_word (SCM dstate); extern scm_bits_t scm_restore_word (SCM dstate);
extern SCM scm_restore_object (SCM dstate); extern void scm_restore_object (SCM *objp, SCM dstate);
extern void scm_restore_cell_object (SCM cell, int n, SCM dstate);
extern SCM scm_binary_write (SCM obj, SCM port); extern SCM scm_binary_write (SCM obj, SCM port);
extern SCM scm_binary_read (SCM port); extern SCM scm_binary_read (SCM port);

8
libguile/keywords.c
View file

@ -69,7 +69,7 @@ keyword_print (SCM exp, SCM port, scm_print_state *pstate)
} }
static void static void
keyword_dealloc (SCM obj, SCM dstate) keyword_dump (SCM obj, SCM dstate)
{ {
SCM sym = scm_keyword_dash_symbol (obj); SCM sym = scm_keyword_dash_symbol (obj);
scm_store_string (SCM_SYMBOL_CHARS (sym), scm_store_string (SCM_SYMBOL_CHARS (sym),
@ -78,7 +78,7 @@ keyword_dealloc (SCM obj, SCM dstate)
} }
static SCM static SCM
keyword_alloc (SCM dstate) keyword_undump (SCM dstate)
{ {
int len; int len;
const char *mem = scm_restore_string (dstate, &len); const char *mem = scm_restore_string (dstate, &len);
@ -156,8 +156,8 @@ scm_init_keywords ()
scm_tc16_keyword = scm_make_smob_type ("keyword", 0); scm_tc16_keyword = scm_make_smob_type ("keyword", 0);
scm_set_smob_mark (scm_tc16_keyword, scm_markcdr); scm_set_smob_mark (scm_tc16_keyword, scm_markcdr);
scm_set_smob_print (scm_tc16_keyword, keyword_print); scm_set_smob_print (scm_tc16_keyword, keyword_print);
scm_set_smob_dump (scm_tc16_keyword, 0, keyword_dealloc, 0); scm_set_smob_dump (scm_tc16_keyword, keyword_dump);
scm_set_smob_undump (scm_tc16_keyword, keyword_alloc, 0, 0); scm_set_smob_undump (scm_tc16_keyword, keyword_undump);
scm_keyword_obarray = scm_c_make_hash_table (256); scm_keyword_obarray = scm_c_make_hash_table (256);
#ifndef SCM_MAGIC_SNARFER #ifndef SCM_MAGIC_SNARFER

28
libguile/smob.c
View file

@ -299,13 +299,9 @@ scm_make_smob_type (char *name, scm_sizet size)
scm_smobs[scm_numsmob].apply_1 = 0; scm_smobs[scm_numsmob].apply_1 = 0;
scm_smobs[scm_numsmob].apply_2 = 0; scm_smobs[scm_numsmob].apply_2 = 0;
scm_smobs[scm_numsmob].apply_3 = 0; scm_smobs[scm_numsmob].apply_3 = 0;
scm_smobs[scm_numsmob].gsubr_type = 0; scm_smobs[scm_numsmob].gsubr_type = 0;
scm_smobs[scm_numsmob].dump_mark = 0; scm_smobs[scm_numsmob].dump = 0;
scm_smobs[scm_numsmob].dump_dealloc = 0; scm_smobs[scm_numsmob].undump = 0;
scm_smobs[scm_numsmob].dump_store = 0;
scm_smobs[scm_numsmob].undump_alloc = 0;
scm_smobs[scm_numsmob].undump_restore = 0;
scm_smobs[scm_numsmob].undump_init = 0;
scm_numsmob++; scm_numsmob++;
} }
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
@ -456,25 +452,15 @@ scm_set_smob_apply (scm_bits_t tc, SCM (*apply) (),
} }
void void
scm_set_smob_dump (scm_bits_t tc, scm_set_smob_dump (scm_bits_t tc, void (*dump) (SCM, SCM))
SCM (*mark) (SCM, SCM),
void (*dealloc) (SCM, SCM),
void (*store) (SCM, SCM))
{ {
scm_smobs[SCM_TC2SMOBNUM (tc)].dump_mark = mark; scm_smobs[SCM_TC2SMOBNUM (tc)].dump = dump;
scm_smobs[SCM_TC2SMOBNUM (tc)].dump_dealloc = dealloc;
scm_smobs[SCM_TC2SMOBNUM (tc)].dump_store = store;
} }
void void
scm_set_smob_undump (scm_bits_t tc, scm_set_smob_undump (scm_bits_t tc, SCM (*undump) (SCM))
SCM (*alloc) (SCM),
void (*restore) (SCM, SCM),
void (*init) (SCM))
{ {
scm_smobs[SCM_TC2SMOBNUM (tc)].undump_alloc = alloc; scm_smobs[SCM_TC2SMOBNUM (tc)].undump = undump;
scm_smobs[SCM_TC2SMOBNUM (tc)].undump_restore = restore;
scm_smobs[SCM_TC2SMOBNUM (tc)].undump_init = init;
} }
SCM SCM

27
libguile/smob.h
View file

@ -69,12 +69,8 @@ typedef struct scm_smob_descriptor
int gsubr_type; /* Used in procprop.c */ int gsubr_type; /* Used in procprop.c */
/* Dump functions */ /* Dump functions */
SCM (*dump_mark) (SCM, SCM); void (*dump) (SCM, SCM);
void (*dump_dealloc) (SCM, SCM); SCM (*undump) (SCM);
void (*dump_store) (SCM, SCM);
SCM (*undump_alloc) (SCM);
void (*undump_restore) (SCM, SCM);
void (*undump_init) (SCM);
} scm_smob_descriptor; } scm_smob_descriptor;
@ -157,27 +153,18 @@ extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate);
extern scm_bits_t scm_make_smob_type (char *name, scm_sizet size); extern scm_bits_t scm_make_smob_type (char *name, scm_sizet size);
extern void scm_set_smob_mark (scm_bits_t tc, extern void scm_set_smob_mark (scm_bits_t tc, SCM (*mark) (SCM));
SCM (*mark) (SCM)); extern void scm_set_smob_free (scm_bits_t tc, scm_sizet (*free) (SCM));
extern void scm_set_smob_free (scm_bits_t tc,
scm_sizet (*free) (SCM));
extern void scm_set_smob_print (scm_bits_t tc, extern void scm_set_smob_print (scm_bits_t tc,
int (*print) (SCM, SCM, scm_print_state*)); int (*print) (SCM, SCM, scm_print_state*));
extern void scm_set_smob_equalp (scm_bits_t tc, extern void scm_set_smob_equalp (scm_bits_t tc, SCM (*equalp) (SCM, SCM));
SCM (*equalp) (SCM, SCM));
extern void scm_set_smob_apply (scm_bits_t tc, extern void scm_set_smob_apply (scm_bits_t tc,
SCM (*apply) (), SCM (*apply) (),
unsigned int req, unsigned int req,
unsigned int opt, unsigned int opt,
unsigned int rst); unsigned int rst);
extern void scm_set_smob_dump (scm_bits_t tc, extern void scm_set_smob_dump (scm_bits_t tc, void (*dump) (SCM, SCM));
SCM (*mark) (SCM, SCM), extern void scm_set_smob_undump (scm_bits_t tc, SCM (*undump) (SCM));
void (*dealloc) (SCM, SCM),
void (*store) (SCM, SCM));
extern void scm_set_smob_undump (scm_bits_t tc,
SCM (*alloc) (SCM),
void (*restore) (SCM, SCM),
void (*init) (SCM));
/* Function for creating smobs */ /* Function for creating smobs */