mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-21 20:12:51 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'serialization' into 'develop'

Browse source 
fix the broken serialization functions for externalizable objects

See merge request embeddable-common-lisp/ecl!128
This commit is contained in:
Daniel Kochmański 2018-12-19 06:49:04 +00:00
commit ed9ebb936b
17 changed files with 362 additions and 77 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/aclocal.m4 vendored
View file

@ -1065,6 +1065,9 @@ if test "${enable_precisegc}" != "no" ; then
else
AC_MSG_RESULT([no])
fi
if test "${enable_serialization}" != "no" ; then
AC_DEFINE([ECL_EXTERNALIZABLE], [], [Use the serialization framework])
fi
])
dnl ----------------------------------------------------------------------

2
src/c/array.d
View file

@ -22,7 +22,7 @@ static const cl_object ecl_aet_name[] = {
ECL_T, /* ecl_aet_object */
@'single-float', /* ecl_aet_sf */
@'double-float', /* ecl_aet_df */
@'bit', /* ecl_aet_bit: cannot be handled with this code */
@'bit', /* ecl_aet_bit */
@'ext::cl-fixnum', /* ecl_aet_fix */
@'ext::cl-index', /* ecl_aet_index */
@'ext::byte8', /* ecl_aet_b8 */

48
src/c/hash.d
View file

@ -950,6 +950,54 @@ cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size,
return h;
}
#ifdef ECL_EXTERNALIZABLE
void
ecl_reconstruct_serialized_hashtable(cl_object h) {
switch (h->hash.test) {
case ecl_htt_eq:
h->hash.get = _ecl_gethash_eq;
h->hash.set = _ecl_sethash_eq;
h->hash.rem = _ecl_remhash_eq;
break;
case ecl_htt_eql:
h->hash.get = _ecl_gethash_eql;
h->hash.set = _ecl_sethash_eql;
h->hash.rem = _ecl_remhash_eql;
break;
case ecl_htt_equal:
h->hash.get = _ecl_gethash_equal;
h->hash.set = _ecl_sethash_equal;
h->hash.rem = _ecl_remhash_equal;
break;
case ecl_htt_equalp:
h->hash.get = _ecl_gethash_equalp;
h->hash.set = _ecl_sethash_equalp;
h->hash.rem = _ecl_remhash_equalp;
break;
case ecl_htt_pack:
h->hash.get = _ecl_gethash_pack;
h->hash.set = _ecl_sethash_pack;
h->hash.rem = _ecl_remhash_pack;
break;
}
if (h->hash.weak != ecl_htt_not_weak) {
h->hash.get = _ecl_gethash_weak;
h->hash.set = _ecl_sethash_weak;
h->hash.rem = _ecl_remhash_weak;
}
if (h->hash.sync_lock != OBJNULL
&& (ecl_t_of(h->hash.sync_lock) == t_lock
|| ecl_t_of(h->hash.sync_lock) == t_rwlock)) {
h->hash.get_unsafe = h->hash.get;
h->hash.set_unsafe = h->hash.set;
h->hash.rem_unsafe = h->hash.rem;
h->hash.get = _ecl_gethash_sync;
h->hash.set = _ecl_sethash_sync;
h->hash.rem = _ecl_remhash_sync;
}
}
#endif
cl_object
cl_hash_table_p(cl_object ht)
{

17
src/c/read.d
View file

@ -2379,11 +2379,18 @@ ecl_init_module(cl_object block, void (*entry_point)(cl_object))
/* Read all data for the library */
#ifdef ECL_EXTERNALIZABLE
{
cl_object v = ecl_deserialize(block->cblock.data_text);
unlikely_if (v->vector.dim < len)
FEreader_error("Not enough data while loading"
"binary file", in, 0);
memcpy(VV, v->vector.self.t, len * sizeof(cl_object));
unlikely_if (block->cblock.data_text == NULL) {
unlikely_if (len > 0)
FEreader_error("Not enough data while loading"
"binary file", in, 0);
} else {
cl_object v = si_deserialize(*(block->cblock.data_text));
unlikely_if (v->vector.dim < len)
FEreader_error("Not enough data while loading"
"binary file", in, 0);
memcpy(VV, v->vector.self.t, perm_len * sizeof(cl_object));
memcpy(VVtemp, v->vector.self.t + perm_len, temp_len * sizeof(cl_object));
}
}
#else
in = make_data_stream(block->cblock.data_text);

200
src/c/serialize.d
View file

@ -15,6 +15,8 @@
#define ECL_DEFINE_AET_SIZE
#include <ecl/internal.h>
#ifdef ECL_EXTERNALIZABLE
struct fake_package {
_ECL_HDR;
cl_object name;
@ -83,10 +85,10 @@ static cl_index object_size[] = {
};
typedef struct pool {
cl_object data;
cl_object hash;
cl_object queue;
cl_object last;
cl_object data; /* vector of bytes containing the serialized objects */
cl_object hash; /* hashtable mapping already serialized objects to indices in data */
cl_object queue; /* queue of objects to be serialized */
cl_object last; /* last cons cell of queue */
} *pool_t;
static cl_index
@ -104,6 +106,8 @@ alloc(pool_t pool, cl_index size)
return fillp;
}
/* Set the tag bits of an index into the array of serialized objects
to zero to make it distinguishable from an ordinary fixnum */
static cl_object
fix_to_ptr(cl_object ptr)
{
@ -118,10 +122,8 @@ enqueue(pool_t pool, cl_object what)
if (ECL_FIXNUMP(what) || ECL_CHARACTERP(what) || what == OBJNULL) {
return what;
}
#ifdef ECL_SMALL_CONS
if (Null(what))
return what;
#endif
index = ecl_gethash_safe(what, pool->hash, OBJNULL);
if (index == OBJNULL) {
cl_object cons;
@ -134,13 +136,11 @@ enqueue(pool_t pool, cl_object what)
return fix_to_ptr(index);
}
#ifdef ECL_SMALL_CONS
typedef struct {
_ECL_HDR;
cl_object car, cdr;
} large_cons;
typedef large_cons *large_cons_ptr;
#endif
static cl_index
serialize_bits(pool_t pool, void *data, cl_index size)
@ -157,7 +157,6 @@ serialize_object_ptr(pool_t pool, cl_object *ptr, cl_index dim)
for (; dim; dim--, index += sizeof(cl_object)) {
cl_object *p = (cl_object *)(pool->data->vector.self.b8 + index);
*p = enqueue(pool, *p);
p++;
}
}
@ -172,12 +171,25 @@ serialize_displaced_vector(pool_t pool, cl_object v)
v->vector.displaced = ECL_NIL;
serialize_vector(pool, v);
} else {
cl_index index = v->vector.self.b8 - to->vector.self.b8;
/* TODO: Implement serialization of displaced bit vectors */
if (v->vector.elttype == ecl_aet_bit) {
FEerror("ECL can not yet serialize displaced bitvectors", 0);
}
cl_index index = (v->vector.self.b8 - to->vector.self.b8) / ecl_aet_size[v->vector.elttype];
v->vector.displaced = enqueue(pool, to);
v->vector.self.b8 = (uint8_t*)index;
}
}
static size_t
vector_self_size(cl_object v) {
if (v->vector.elttype == ecl_aet_bit) {
return ROUND_TO_WORD((v->vector.dim + (CHAR_BIT-1))/CHAR_BIT);
} else {
return ROUND_TO_WORD(v->vector.dim * ecl_aet_size[v->vector.elttype]);
}
}
static void
serialize_vector(pool_t pool, cl_object v)
{
@ -186,16 +198,22 @@ serialize_vector(pool_t pool, cl_object v)
} else if (v->vector.elttype == ecl_aet_object) {
serialize_object_ptr(pool, v->vector.self.t, v->vector.dim);
} else {
serialize_bits(pool, v->vector.self.b8,
v->vector.dim * ecl_aet_size[v->vector.elttype]);
serialize_bits(pool, v->vector.self.b8, vector_self_size(v));
}
}
static void
serialize_array(pool_t pool, cl_object a)
serialize_hashtable(pool_t pool, cl_object h)
{
serialize_bits(pool, a->array.dims, sizeof(cl_index) * a->array.rank);
serialize_vector(pool, a);
/* FIXME: Serializing all of h->hash.data is a big waste if the
hashtable has only a small number of entries. */
cl_index size = h->hash.size;
cl_index index = serialize_bits(pool, h->hash.data, size*sizeof(struct ecl_hashtable_entry));
for (; size; size--, index += sizeof(struct ecl_hashtable_entry)) {
struct ecl_hashtable_entry *p = (struct ecl_hashtable_entry *)(pool->data->vector.self.b8 + index);
p->key = enqueue(pool, p->key);
p->value = enqueue(pool, p->value);
}
}
static void
@ -203,7 +221,6 @@ serialize_one(pool_t pool, cl_object what)
{
cl_index bytes, index;
cl_object buffer;
#ifdef ECL_SMALL_CONS
if (ECL_LISTP(what)) {
cl_index bytes = ROUND_TO_WORD(sizeof(large_cons));
cl_index index = alloc(pool, bytes);
@ -211,33 +228,31 @@ serialize_one(pool_t pool, cl_object what)
(large_cons_ptr)(pool->data->vector.self.b8 + index);
memset(cons, 0, bytes);
cons->t = t_list;
cons->car = enqueue(pool, ECL_CONS_CAR(what));
cons->cdr = enqueue(pool, ECL_CONS_CDR(what));
if (!Null(what)) {
cons->car = enqueue(pool, ECL_CONS_CAR(what));
cons->cdr = enqueue(pool, ECL_CONS_CDR(what));
}
return;
}
#endif
bytes = object_size[what->d.t];
bytes = object_size[ecl_t_of(what)];
index = alloc(pool, bytes);
buffer = (cl_object)(pool->data->vector.self.b8 + index);
memcpy(buffer, what, bytes);
switch (buffer->d.t) {
switch (ecl_t_of(what)) {
case t_singlefloat:
case t_doublefloat:
#ifdef ECL_LONG_FLOAT
case t_longfloat:
#endif
break;
#ifndef ECL_SMALL_CONS
case t_list:
buffer->cons.car = enqueue(pool, buffer->cons.car);
buffer->cons.cdr = enqueue(pool, buffer->cons.car);
break;
#endif
case t_bignum: {
cl_fixnum size = ECL_BIGNUM_SIZE(buffer);
cl_index dim = ((size < 0) ? (-size) : size);
cl_index bytes = dim * sizeof(mp_limb_t);
serialize_bits(pool, ECL_BIGNUM_LIMBS(buffer), bytes);
int8_t sign = mpz_sgn(buffer->big.big_num);
serialize_bits(pool, &sign, 1);
cl_index bytes = (mpz_sizeinbase(buffer->big.big_num, 2) + 7) / 8;
serialize_bits(pool, &bytes, sizeof(cl_index));
cl_index index = alloc(pool, bytes);
cl_index bytes_written;
mpz_export(pool->data->vector.self.b8 + index, &bytes_written, 1, 1, 1, 0, buffer->big.big_num);
break;
}
case t_ratio: {
@ -250,6 +265,12 @@ serialize_one(pool_t pool, cl_object what)
buffer->complex.imag = enqueue(pool, buffer->complex.imag);
break;
}
case t_hashtable:
buffer->hash.sync_lock = enqueue(pool, buffer->hash.sync_lock);
buffer->hash.rehash_size = enqueue(pool, buffer->hash.rehash_size);
buffer->hash.threshold = enqueue(pool, buffer->hash.threshold);
serialize_hashtable(pool, buffer);
break;
#ifdef ECL_UNICODE
case t_string:
#endif
@ -260,9 +281,11 @@ serialize_one(pool_t pool, cl_object what)
break;
}
case t_array: {
cl_index bytes = ROUND_TO_WORD(buffer->array.rank *
sizeof(cl_index));
serialize_bits(pool, buffer->array.dims, bytes);
serialize_bits(pool, buffer->array.dims, sizeof(cl_index) * buffer->array.rank);
/* We might have allocated memory in pool->data and thus the
adress of pool->data->vector.self might have changed, hence we
have to reload buffer. */
buffer = (cl_object)(pool->data->vector.self.b8 + index);
serialize_vector(pool, buffer);
break;
}
@ -296,6 +319,7 @@ serialize_one(pool_t pool, cl_object what)
case t_bclosure: {
buffer->bclosure.code = enqueue(pool, buffer->bclosure.code);
buffer->bclosure.lex = enqueue(pool, buffer->bclosure.lex);
break;
}
case t_bytecodes: {
buffer->bytecodes.name = enqueue(pool, buffer->bytecodes.name);
@ -305,6 +329,7 @@ serialize_one(pool_t pool, cl_object what)
buffer->bytecodes.file_position = enqueue(pool, buffer->bytecodes.file_position);
buffer->bytecodes.code_size = serialize_bits(pool, buffer->bytecodes.code,
buffer->bytecodes.code_size);
break;
}
default:
FEerror("Unable to serialize object ~A", 1, what);
@ -352,7 +377,7 @@ si_serialize(cl_object root)
static void *
reconstruct_bits(uint8_t *data, cl_index bytes)
{
void *output = ecl_alloc_atomic(bytes);
void *output = ecl_alloc_atomic(ROUND_TO_WORD(bytes));
memcpy(output, data, bytes);
return output;
}
@ -360,7 +385,7 @@ reconstruct_bits(uint8_t *data, cl_index bytes)
static void *
reconstruct_object_ptr(uint8_t *data, cl_index bytes)
{
void *output = ecl_alloc(bytes);
void *output = ecl_alloc(ROUND_TO_WORD(bytes));
memcpy(output, data, bytes);
return output;
}
@ -377,13 +402,11 @@ static uint8_t *
reconstruct_vector(cl_object v, uint8_t *data)
{
if (v->vector.displaced == ECL_NIL) {
cl_type t = v->vector.elttype;
cl_index size = v->vector.dim * ecl_aet_size[t];
cl_index bytes = ROUND_TO_WORD(size);
if (t == ecl_aet_object) {
cl_index bytes = vector_self_size(v);
if (v->vector.elttype == ecl_aet_object) {
v->vector.self.t = reconstruct_object_ptr(data, bytes);
} else {
v->vector.self.t = reconstruct_bits(data, size);
v->vector.self.t = reconstruct_bits(data, bytes);
}
data += bytes;
}
@ -398,10 +421,19 @@ reconstruct_array(cl_object a, uint8_t *data)
return reconstruct_vector(a, data + bytes);
}
static uint8_t *
reconstruct_hashtable(cl_object h, uint8_t *data)
{
cl_index bytes = ROUND_TO_WORD(h->hash.size * sizeof(struct ecl_hashtable_entry));
h->hash.data = ecl_alloc(bytes);
memcpy(h->hash.data, data, bytes);
return data + bytes;
}
static uint8_t *
duplicate_object(uint8_t *data, cl_object *output)
{
cl_type t = ((cl_object)data)->d.t;
cl_type t = ecl_t_of((cl_object)data);
cl_object o = ecl_alloc_object(t);
cl_index bytes = object_size[t];
memcpy(o, data, bytes);
@ -413,15 +445,37 @@ static uint8_t *
reconstruct_one(uint8_t *data, cl_object *output)
{
cl_object o = (cl_object)data;
switch (o->d.t) {
#ifdef ECL_SMALL_CONS
switch (ecl_t_of(o)) {
case t_list: {
large_cons_ptr c = (large_cons_ptr)data;
*output = ecl_cons(c->car, c->cdr);
cl_object car = c->car;
cl_object cdr = c->cdr;
if (car == (cl_object) 0 && cdr == (cl_object) 0) {
*output = ECL_NIL;
} else {
*output = ecl_cons(car, cdr);
}
data += ROUND_TO_WORD(sizeof(large_cons));
break;
}
#endif
case t_bignum: {
data = duplicate_object(data, output);
int8_t sign = (int8_t) *data;
data += ROUND_TO_WORD(1);
cl_index bytes = (cl_index) *data;
data += ROUND_TO_WORD(sizeof(cl_index));
mpz_init((*output)->big.big_num);
mpz_import((*output)->big.big_num, bytes, 1, 1, 1, 0, data);
if (sign == -1) {
mpz_neg((*output)->big.big_num, (*output)->big.big_num);
}
data += ROUND_TO_WORD(bytes);
break;
}
case t_hashtable:
data = duplicate_object(data, output);
data = reconstruct_hashtable(*output, data);
break;
#ifdef ECL_UNICODE
case t_string:
#endif
@ -446,6 +500,7 @@ reconstruct_one(uint8_t *data, cl_object *output)
case t_bytecodes:
data = duplicate_object(data, output);
data = reconstruct_bytecodes(*output, data);
break;
default:
data = duplicate_object(data, output);
}
@ -455,7 +510,7 @@ reconstruct_one(uint8_t *data, cl_object *output)
static cl_object
get_object(cl_object o_or_index, cl_object *o_list)
{
if (ECL_IMMEDIATE(o_or_index)) {
if (ECL_IMMEDIATE(o_or_index) || o_or_index == OBJNULL) {
return o_or_index;
} else {
cl_index i = (cl_index)o_or_index >> 2;
@ -467,8 +522,7 @@ static void
fixup_vector(cl_object v, cl_object *o_list)
{
if (!ECL_IMMEDIATE(v->vector.displaced)) {
cl_object disp = get_object(v->vector.displaced, o_list);
cl_object to = ECL_CONS_CAR(disp);
cl_object to = get_object(v->vector.displaced, o_list);
if (to != ECL_NIL) {
cl_index offset = (cl_index)v->vector.self.b8;
v->vector.displaced = ECL_NIL;
@ -485,17 +539,30 @@ fixup_vector(cl_object v, cl_object *o_list)
}
}
static void
fixup_hashtable(cl_object h, cl_object *o_list)
{
cl_index i;
for (i = 0; i < h->hash.size; i++) {
h->hash.data[i].key = get_object(h->hash.data[i].key, o_list);
h->hash.data[i].value = get_object(h->hash.data[i].value, o_list);
}
h->hash.rehash_size = get_object(h->hash.rehash_size, o_list);
h->hash.threshold = get_object(h->hash.threshold, o_list);
ecl_reconstruct_serialized_hashtable(h);
}
static void
fixup(cl_object o, cl_object *o_list)
{
#ifdef ECL_SMALL_CONS
if (ECL_LISTP(o)) {
ECL_RPLACA(o, get_object(ECL_CONS_CAR(o), o_list));
ECL_RPLACD(o, get_object(ECL_CONS_CDR(o), o_list));
if (!Null(o)) {
ECL_RPLACA(o, get_object(ECL_CONS_CAR(o), o_list));
ECL_RPLACD(o, get_object(ECL_CONS_CDR(o), o_list));
}
return;
}
#endif
switch (o->d.t) {
switch (ecl_t_of(o)) {
case t_ratio:
o->ratio.den = get_object(o->ratio.den, o_list);
o->ratio.num = get_object(o->ratio.num, o_list);
@ -504,6 +571,9 @@ fixup(cl_object o, cl_object *o_list)
o->complex.real = get_object(o->complex.real, o_list);
o->complex.imag = get_object(o->complex.imag, o_list);
break;
case t_hashtable:
fixup_hashtable(o, o_list);
break;
#ifdef ECL_UNICODE
case t_string:
#endif
@ -548,6 +618,7 @@ fixup(cl_object o, cl_object *o_list)
cl_object
ecl_deserialize(uint8_t *raw)
{
cl_env_ptr the_env = ecl_process_env();
cl_index *data = (cl_index*)raw;
cl_index i, num_el = data[1];
cl_object *output = ecl_alloc(sizeof(cl_object) * num_el);
@ -557,20 +628,31 @@ ecl_deserialize(uint8_t *raw)
}
for (i = 0; i < num_el; i++) {
cl_object package = output[i];
if (!ECL_IMMEDIATE(package) && package->d.t == t_package) {
if (ecl_t_of(package) == t_package) {
cl_object name = get_object(package->pack.name,
output);
output[i] = ecl_find_package_nolock(name);
if (Null(output[i])) {
unlikely_if (Null(the_env->packages_to_be_created_p)) {
FEerror("There is no package with the name ~A.",
1, name);
}
output[i] = _ecl_package_to_be_created(the_env, name);
}
}
}
for (i = 0; i < num_el; i++) {
cl_object symbol = output[i];
if (!ECL_IMMEDIATE(symbol) && symbol->d.t == t_symbol) {
if (ecl_t_of(symbol) == t_symbol) {
struct fake_symbol *s = (struct fake_symbol *)symbol;
cl_object name = get_object(s->name, output);
cl_object pack = get_object(s->pack, output);
int flag;
output[i] = ecl_intern(name, pack, &flag);
if (Null(pack)) {
output[i] = cl_make_symbol(name);
} else {
int flag;
output[i] = ecl_intern(name, pack, &flag);
}
}
}
for (i = 0; i < num_el; i++) {
@ -585,3 +667,5 @@ si_deserialize(cl_object data)
{
@(return ecl_deserialize(data->vector.self.b8));
}
#endif /* ECL_EXTERNALIZABLE */

11
src/c/symbols_list.h
View file

@ -56,6 +56,11 @@ typedef struct {
# undef GRAY_
# define GRAY_ SYS_
#endif
#ifdef ECL_EXTERNALIZABLE
# define IF_EXTERNALIZABLE(x) x
#else
# define IF_EXTERNALIZABLE(x) NULL
#endif
#ifdef ECL_SSE2
# define IF_SSE2(x) x
#else
@ -2066,8 +2071,10 @@ cl_symbols[] = {
{SYS_ "CTYPECASE-ERROR", SI_ORDINARY, ECL_NAME(si_ctypecase_error), 3, OBJNULL},
{SYS_ "DO-CHECK-TYPE", SI_ORDINARY, ECL_NAME(si_do_check_type), 4, OBJNULL},
{SYS_ "SERIALIZE", SI_ORDINARY, si_serialize, 1, OBJNULL},
{SYS_ "DESERIALIZE", SI_ORDINARY, si_deserialize, 1, OBJNULL},
/* #ifdef ECL_EXTERNALIZABLE */
{SYS_ "SERIALIZE", SI_ORDINARY, IF_EXTERNALIZABLE(si_serialize), 1, OBJNULL},
{SYS_ "DESERIALIZE", SI_ORDINARY, IF_EXTERNALIZABLE(si_deserialize), 1, OBJNULL},
/* #endif */
{EXT_ "ARRAY-ELEMENT-TYPE-BYTE-SIZE", EXT_ORDINARY, si_array_element_type_byte_size, 1, OBJNULL},

11
src/c/symbols_list2.h
View file

@ -56,6 +56,11 @@ typedef struct {
# undef GRAY_
# define GRAY_ SYS_
#endif
#ifdef ECL_EXTERNALIZABLE
# define IF_EXTERNALIZABLE(x) x
#else
# define IF_EXTERNALIZABLE(x) NULL
#endif
#ifdef ECL_SSE2
# define IF_SSE2(x) x
#else
@ -2066,8 +2071,10 @@ cl_symbols[] = {
{SYS_ "CTYPECASE-ERROR","ECL_NAME(si_ctypecase_error)"},
{SYS_ "DO-CHECK-TYPE","ECL_NAME(si_do_check_type)"},
{SYS_ "SERIALIZE","si_serialize"},
{SYS_ "DESERIALIZE","si_deserialize"},
/* #ifdef ECL_EXTERNALIZABLE */
{SYS_ "SERIALIZE",IF_EXTERNALIZABLE("si_serialize")},
{SYS_ "DESERIALIZE",IF_EXTERNALIZABLE("si_deserialize")},
/* #endif */
{EXT_ "ARRAY-ELEMENT-TYPE-BYTE-SIZE","si_array_element_type_byte_size"},

26
src/cmp/cmpwt.lsp
View file

@ -84,6 +84,7 @@
(t
"")))
#-externalizable
(defun data-c-dump (filename)
(labels ((produce-strings ()
;; Only Windows has a size limit in the strings it creates.
@ -98,7 +99,7 @@
for i from 0 below l by max-string-size
for this-l = (min (- l i) max-string-size)
collect (make-array this-l :displaced-to string
:element-type 'character
:element-type (array-element-type string)
:displaced-index-offset i)))
(output-one-c-string (name string stream)
(let* ((*wt-string-size* 0)
@ -127,6 +128,29 @@
;; Ensure a final newline or some compilers complain
(terpri stream)))))
#+externalizable
(defun data-c-dump (filename)
(with-open-file (stream filename :direction :output :if-does-not-exist :create
:if-exists :supersede :external-format :default)
(let ((data (data-dump-array)))
(if (plusp (length data))
(let ((s (with-output-to-string (stream)
(loop for i below (length data) do
(princ (elt data i) stream)
(if (< i (1- (length data)))
(princ "," stream))))))
(format stream "static uint8_t serialization_data[] = {~A};~%" s)
(format stream "static const struct ecl_vector compiler_data_text1[] = {{
(int8_t)t_vector, 0, ecl_aet_b8, 0,
ECL_NIL, (cl_index)~D, (cl_index)~D,
{ .b8=serialization_data } }};~%"
(length data) (length data))
(format stream "static const cl_object compiler_data_text[] = {
(cl_object)compiler_data_text1}; "))
(princ "#define compiler_data_text NULL" stream))
;; Ensure a final newline or some compilers complain
(terpri stream))))
(defun data-empty-loc ()
(add-object 0 :duplicate t :permanent t))

17
src/configure vendored
View file

@ -803,6 +803,7 @@ enable_c99complex
enable_smallcons
enable_gengc
enable_precisegc
enable_serialization
enable_debug
with_debug_cflags
with_profile_cflags
@ -1478,6 +1479,9 @@ Optional Features:
--enable-precisegc use type information during garbage collection.
Requires Boehm-Weiser gc (EXPERIMENTAL). (no|yes,
default=NO)
--enable-serialization use serialization framework instead of the reader to
save externalizable objects in compiled files
(EXPERIMENTAL). (no|yes, default=NO)
--enable-debug enable various debugging features (default=NO)
Optional Packages:
@ -2955,6 +2959,14 @@ else
fi
# Check whether --enable-serialization was given.
if test "${enable_serialization+set}" = set; then :
enableval=$enable_serialization;
else
enable_serialization=no
fi
# Check whether --enable-debug was given.
if test "${enable_debug+set}" = set; then :
enableval=$enable_debug; DEBUG_CFLAGS="-g -O0"; CFLAGS="$CFLAGS -g -O0"
@ -6221,6 +6233,11 @@ $as_echo "yes" >&6; }
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
$as_echo "no" >&6; }
fi
if test "${enable_serialization}" != "no" ; then
$as_echo "#define ECL_EXTERNALIZABLE /**/" >>confdefs.h
fi
fi

6
src/configure.ac
View file

@ -259,6 +259,12 @@ AC_ARG_ENABLE(precisegc,
[(no|yes, default=NO)]),
[enable_precisegc=${enableval}], [enable_precisegc=no] )
AC_ARG_ENABLE(serialization,
AS_HELP_STRING( [--enable-serialization],
[use serialization framework instead of the reader to save externalizable objects in compiled files (EXPERIMENTAL).]
[(no|yes, default=NO)]),
[], [enable_serialization=no] )
AC_ARG_ENABLE(debug,
AS_HELP_STRING( [--enable-debug],
[enable various debugging features]

3
src/ecl/configpre.h
View file

@ -21,6 +21,9 @@
/* Stack grows downwards */
#undef ECL_DOWN_STACK
/* Use the serialization framework */
#undef ECL_EXTERNALIZABLE
/* ECL_IEEE_FP */
#undef ECL_IEEE_FP

3
src/h/config.h.in
View file

@ -218,6 +218,9 @@ typedef unsigned char ecl_base_char;
/* Use CMU Common-Lisp's FORMAT routine */
#undef ECL_CMU_FORMAT
/* Use the serialization framework */
#undef ECL_EXTERNALIZABLE
/*
* C macros for inlining, denoting probable code paths and other stuff
* that makes better code. Most of it is GCC specific.

8
src/h/external.h
View file

@ -1567,6 +1567,14 @@ extern ECL_API cl_fixnum ecl_length(cl_object x);
extern ECL_API cl_object ecl_subseq(cl_object seq, cl_index start, cl_index limit);
extern ECL_API cl_object ecl_copy_seq(cl_object seq);
#ifdef ECL_EXTERNALIZABLE
/* serialize.d */
extern cl_object si_serialize(cl_object root);
extern cl_object si_deserialize(cl_object root);
#endif
#ifdef ECL_SSE2
/* sse2.c */

7
src/h/internal.h
View file

@ -315,6 +315,9 @@ extern cl_object si_formatter_aux _ECL_ARGS((cl_narg narg, cl_object strm, cl_ob
/* hash.d */
extern cl_object ecl_extend_hashtable(cl_object hashtable);
#ifdef ECL_EXTERNALIZABLE
extern void ecl_reconstruct_serialized_hashtable(cl_object h);
#endif
/* gfun.d, kernel.lsp */
@ -450,11 +453,11 @@ extern bool ecl_wild_string_p(cl_object item);
typedef struct { cl_index start, end, length; } cl_index_pair;
extern ECL_API cl_index_pair ecl_sequence_start_end(cl_object fun, cl_object s, cl_object start, cl_object end);
#ifdef ECL_EXTERNALIZABLE
/* serialize.d */
extern cl_object si_serialize(cl_object root);
extern cl_object si_deserialize(cl_object root);
extern cl_object ecl_deserialize(uint8_t *data);
#endif
/* string.d */
#define ecl_vector_start_end ecl_sequence_start_end

2
src/h/object.h
View file

@ -33,8 +33,6 @@ typedef int bool;
#endif
typedef unsigned char byte;
/* #define ECL_EXTERNALIZABLE */
/*
Implementation types.
Verify that it matches printer/write_ugly.d

2
src/lsp/defstruct.lsp
View file

@ -292,7 +292,7 @@
(new-read-only (fourth new-slot)))
(cond ((and (null new-read-only)
old-read-only)
(error "Tried to turn a read only slot ~A into writtable."
(error "Tried to turn a read only slot ~A into writeable."
slot-name))
((eq new-read-only :unknown)
(setf new-read-only old-read-only)))

73
src/tests/normal-tests/mixed.lsp
View file

@ -204,7 +204,7 @@
(signals arithmetic-error (/ a b))))
;;; Data: 2017-01-20
;;; Date: 2017-01-20
;;; Description:
;;;
;;; `dolist' macroexpansion yields result which doesn't have a
@ -227,7 +227,7 @@
:next))))
;;; Data: 2017-07-02
;;; Date: 2017-07-02
;;; Description:
;;;
;;; Function `ecl_new_binding_index' called `si_set_finalizer',
@ -252,7 +252,7 @@
(delete-file "aux-cl-0003.fasc"))
(is-eql 2 (mix.0015.fun)))
;;; Data: 2018-05-08
;;; Date: 2018-05-08
;;; Description:
;;;
;;; Better handling of fifos. This test will most likely fail on Windows (this
@ -291,3 +291,70 @@
(is (equal "foobar" (read-line stream2 nil :foo)))))
;; clean up
(ext:run-program "rm" '("-rf" "my-fifo") :output t))
;;; Date: 2018-12-02
;;; Description:
;;;
;;; Serialization/Deserialization tests
#+externalizable
(test mix.0017.serialization
(let* ((vector (make-array 4 :element-type 'ext:byte16 :initial-contents #(1 2 3 4)))
(to-be-serialized
(vector nil ; 1: empty list
'(1 2) ; 2: non-empty list
#\q ; 3: character
42 ; 4: fixnum
(+ 10 most-positive-fixnum) ; 5: bignum
2/3 ; 6: ratio
12.3f4 ; 7-9: floats
13.2d4
#+long-float 14.2l3
#C(4 7) ; 10: complex
#.(find-package "COMMON-LISP-USER") ; 11: package
'q ; 12: symbol
;; 13: hash-table
(let ((ht (make-hash-table)))
(setf (gethash :foo ht) :abc)
(setf (gethash :bar ht) :def)
ht)
;; 14: array
(let ((a (make-array '(2 2) :initial-element 0)))
(setf (aref a 0 0) 'q)
(setf (aref a 0 1) 1/5)
a)
vector ; 15: non-displaced vector
;; 16: displaced vector
(make-array 3 :element-type 'ext:byte16
:displaced-to vector
:displaced-index-offset 1)
"a∩b∈c" ; 17: string
(make-string 3 :initial-element #\q :element-type 'base-char) ; 18: base-string
(make-array 6 :element-type 'bit :initial-contents #(0 1 0 1 1 0)) ; 19: bit-vector
;; stream: not externalizable?
;; 20: random-state
(let ((r (make-random-state)))
(random 10 r)
r)
;; readtable: not externalizable
#P"/foo/bar/whatever.gif" ; 21: pathname
;; TODO: other objects
))
(deserialized (si::deserialize (si::serialize to-be-serialized))))
(is-true (equalp (subseq to-be-serialized 0 12)
(subseq deserialized 0 12)))
(is-true (loop for key being the hash-keys of (elt to-be-serialized 12)
if (not (eq (gethash key (elt to-be-serialized 12))
(gethash key (elt deserialized 12))))
return nil
finally (return t)))
(is-true (equalp (subseq to-be-serialized 13 16)
(subseq deserialized 13 16)))
(is-true (and (equalp (multiple-value-list (array-displacement (elt to-be-serialized 15)))
(multiple-value-list (array-displacement (elt to-be-serialized 15))))))
(is-true (equal (elt to-be-serialized 16) (elt deserialized 16)))
(is-true (equal (elt to-be-serialized 17) (elt deserialized 17)))
(is-true (equal (elt to-be-serialized 18) (elt deserialized 18)))
(is-true (equalp (elt to-be-serialized 19) (elt deserialized 19)))
(is-true (equal (elt to-be-serialized 20) (elt deserialized 20)))
))