From 76941e25dcfdb399cfa6025bdff2d4df5d255b5c Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Tue, 4 Dec 2018 23:15:33 +0100 Subject: [PATCH] fix the broken serialization functions for externalizable objects --- src/aclocal.m4 | 3 + src/c/array.d | 2 +- src/c/hash.d | 48 ++++++++ src/c/read.d | 17 ++- src/c/serialize.d | 200 ++++++++++++++++++++++--------- src/c/symbols_list.h | 11 +- src/c/symbols_list2.h | 11 +- src/cmp/cmpwt.lsp | 26 +++- src/configure | 17 +++ src/configure.ac | 6 + src/ecl/configpre.h | 3 + src/h/config.h.in | 3 + src/h/external.h | 8 ++ src/h/internal.h | 7 +- src/h/object.h | 2 - src/lsp/defstruct.lsp | 2 +- src/tests/normal-tests/mixed.lsp | 73 ++++++++++- 17 files changed, 362 insertions(+), 77 deletions(-) diff --git a/src/aclocal.m4 b/src/aclocal.m4 index e6f052ee8..1f5cd89d4 100644 --- a/src/aclocal.m4 +++ b/src/aclocal.m4 @@ -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 ---------------------------------------------------------------------- diff --git a/src/c/array.d b/src/c/array.d index 5e9b82b2d..62388f4b0 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -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 */ diff --git a/src/c/hash.d b/src/c/hash.d index 4c5c00c16..4334209ac 100644 --- a/src/c/hash.d +++ b/src/c/hash.d @@ -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) { diff --git a/src/c/read.d b/src/c/read.d index 0a239512e..c0b5c91d6 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -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); diff --git a/src/c/serialize.d b/src/c/serialize.d index 56a7c3a9f..b357ffcef 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -15,6 +15,8 @@ #define ECL_DEFINE_AET_SIZE #include +#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 */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 6d6df48d6..1df966dd3 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 654f33fdb..2cf73fc5b 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -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"}, diff --git a/src/cmp/cmpwt.lsp b/src/cmp/cmpwt.lsp index c5277ecc1..1404e84a5 100644 --- a/src/cmp/cmpwt.lsp +++ b/src/cmp/cmpwt.lsp @@ -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)) diff --git a/src/configure b/src/configure index 836890ff4..2aca24a71 100755 --- a/src/configure +++ b/src/configure @@ -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 diff --git a/src/configure.ac b/src/configure.ac index 297482eb0..036bf7ef7 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -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] diff --git a/src/ecl/configpre.h b/src/ecl/configpre.h index 96795696f..c672170fa 100644 --- a/src/ecl/configpre.h +++ b/src/ecl/configpre.h @@ -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 diff --git a/src/h/config.h.in b/src/h/config.h.in index 6a68669bf..e8e40705c 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -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. diff --git a/src/h/external.h b/src/h/external.h index cf49fd26a..7d90b8d56 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -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 */ diff --git a/src/h/internal.h b/src/h/internal.h index 44e683310..e3a8ca9ec 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -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 diff --git a/src/h/object.h b/src/h/object.h index c0f5124de..9227408da 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -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 diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index 48970a1e4..fbc516967 100644 --- a/src/lsp/defstruct.lsp +++ b/src/lsp/defstruct.lsp @@ -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))) diff --git a/src/tests/normal-tests/mixed.lsp b/src/tests/normal-tests/mixed.lsp index 007de5235..e232bbdc8 100644 --- a/src/tests/normal-tests/mixed.lsp +++ b/src/tests/normal-tests/mixed.lsp @@ -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))) + ))