diff --git a/src/CHANGELOG b/src/CHANGELOG index 0a754be24..98bc601e2 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -29,7 +29,12 @@ ECL 9.9.1: object and the data for the GMP integer itself. Since it can be now allocated as an atomic (i.e. pointerless) region of memory, the garbage collector has to work less for marking and collecting them. - + + - The function ecl_alloc_simple_vector() also creates arrays as a compact unit + with pointerfree memory whenever possible. + + - The functions cl_alloc_simple_{base,extended}_string() now carry the prefix + ecl_ instead of cl_, and they are simple aliases for ecl_alloc_simple_vector. ;;; Local Variables: *** ;;; mode:text *** diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 8a60838e5..f3fc48c79 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -133,7 +133,7 @@ mangle_name(cl_object output, unsigned char *source, int l) symbol = ecl_symbol_name(symbol); l = symbol->base_string.fillp; source = symbol->base_string.self; - output = cl_alloc_simple_base_string(ecl_length(package) + l + 1); + output = ecl_alloc_simple_base_string(ecl_length(package) + l + 1); if (is_symbol && source[0] == '*') { if (l > 2 && source[l-1] == '*') l--; c = 'V'; diff --git a/src/c/array.d b/src/c/array.d index 8ea0c59a2..ef15f0f35 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -18,6 +18,7 @@ #include #include #include +#include static const cl_index ecl_aet_size[] = { sizeof(cl_object), /* aet_object */ @@ -502,6 +503,16 @@ si_make_vector(cl_object etype, cl_object dim, cl_object adj, @(return x) } +cl_object * +alloc_pointerfull_memory(cl_index l) +{ + cl_object *p = ecl_alloc_align(sizeof(cl_object) * l, sizeof(cl_object)); + cl_index i; + for (i = 0; l--;) + p[i++] = Cnil; + return p; +} + void ecl_array_allocself(cl_object x) { @@ -509,20 +520,14 @@ ecl_array_allocself(cl_object x) cl_index i, d = x->array.dim; switch (t) { /* assign self field only after it has been filled, for GC sake */ - case aet_object: { - cl_object *elts; - elts = (cl_object *)ecl_alloc_align(sizeof(cl_object)*d, sizeof(cl_object)); - for (i = 0; i < d; i++) - elts[i] = Cnil; - x->array.self.t = elts; + case aet_object: + x->array.self.t = alloc_pointerfull_memory(d); return; - } #ifdef ECL_UNICODE case aet_ch: { ecl_character *elts; d *= sizeof(ecl_character); elts = (ecl_character *)ecl_alloc_atomic_align(d, sizeof(ecl_character)); - memset(elts, 0, d); x->string.self = elts; return; } @@ -540,6 +545,51 @@ ecl_array_allocself(cl_object x) } } +cl_object +ecl_alloc_simple_vector(cl_index l, cl_elttype aet) +{ + cl_object x; + + switch (aet) { + case aet_bc: + x = ecl_alloc_compact_object(t_base_string, l+1); + x->base_string.self = ECL_COMPACT_OBJECT_EXTRA(x); + memset(x->base_string.self, 0, l+1); + break; +#ifdef ECL_UNICODE + case aet_ch: + { + cl_index bytes = sizeof(ecl_character) * l; + x = ecl_alloc_compact_object(t_string, bytes); + x->string.self = ECL_COMPACT_OBJECT_EXTRA(x); + } + break; +#endif + case aet_bit: + { + cl_index bytes = (l + (CHAR_BIT-1))/CHAR_BIT; + x = ecl_alloc_compact_object(t_bitvector, bytes); + x->vector.self.bit = ECL_COMPACT_OBJECT_EXTRA(x); + x->vector.offset = 0; + } + break; + case aet_object: + { + x = ecl_alloc_object(t_vector); + x->vector.self.t = alloc_pointerfull_memory(l); + } + break; + default: + x = ecl_alloc_compact_object(t_vector, l * ecl_aet_size[aet]); + x->vector.self.bc = ECL_COMPACT_OBJECT_EXTRA(x); + } + x->base_string.elttype = aet; + x->base_string.flags = 0; /* no fill pointer, not adjustable */ + x->base_string.displaced = Cnil; + x->base_string.dim = x->base_string.fillp = l; + return x; +} + cl_elttype ecl_symbol_to_elttype(cl_object x) { diff --git a/src/c/big.d b/src/c/big.d index 88cf3a5b0..694f9a571 100644 --- a/src/c/big.d +++ b/src/c/big.d @@ -37,13 +37,8 @@ _ecl_big_copy(cl_object old) cl_fixnum size = old->big.big_size; cl_index dim = (size < 0)? (-size) : size; cl_index bytes = dim * sizeof(mp_limb_t); -#ifdef ECL_COMPACT_OBJECT_EXTRA cl_object new_big = ecl_alloc_compact_object(t_bignum, bytes); new_big->big.big_limbs = ECL_COMPACT_OBJECT_EXTRA(new_big); -#else - cl_object new_big = ecl_alloc_object(t_bignum); - new_big->big.big_limbs = ecl_alloc_atomic(bytes); -#endif new_big->big.big_size = size; new_big->big.big_dim = dim; memcpy(new_big->big.big_limbs, old->big.big_limbs, bytes); diff --git a/src/c/file.d b/src/c/file.d index 16f2d7bdc..0f179c1dd 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -1463,7 +1463,7 @@ ecl_make_string_output_stream(cl_index line_length, int extended) #ifdef ECL_UNICODE cl_object s = extended? ecl_alloc_adjustable_extended_string(line_length) : - cl_alloc_adjustable_base_string(line_length); + ecl_alloc_adjustable_base_string(line_length); #else cl_object s = cl_alloc_adjustable_base_string(line_length); #endif diff --git a/src/c/num_rand.d b/src/c/num_rand.d index 3cfa76f93..6c2b0258f 100644 --- a/src/c/num_rand.d +++ b/src/c/num_rand.d @@ -63,7 +63,7 @@ cl_object init_random_state() { cl_index bytes = sizeof(ulong) * (MT_N + 1); - cl_object a = cl_alloc_simple_base_string(bytes); + cl_object a = ecl_alloc_simple_base_string(bytes); ulong *mt = (ulong*)a->base_string.self; int j; #if !defined(_MSC_VER) && !defined(mingw32) diff --git a/src/c/sequence.d b/src/c/sequence.d index c60dde973..d2212f09f 100644 --- a/src/c/sequence.d +++ b/src/c/sequence.d @@ -19,42 +19,6 @@ #include #include -/* - I know the following name is not good. -*/ -cl_object -ecl_alloc_simple_vector(cl_index l, cl_elttype aet) -{ - cl_object x; - - switch (aet) { - case aet_bc: - return cl_alloc_simple_base_string(l); -#ifdef ECL_UNICODE - case aet_ch: - return cl_alloc_simple_extended_string(l); -#endif - case aet_bit: - x = ecl_alloc_object(t_bitvector); - x->vector.flags = 0; /* no fill pointer, not adjustable */ - x->vector.displaced = Cnil; - x->vector.dim = x->vector.fillp = l; - x->vector.offset = 0; - x->vector.self.bit = NULL; - x->vector.elttype = aet; - break; - default: - x = ecl_alloc_object(t_vector); - x->vector.flags = 0; /* no fill pointer, not adjustable */ - x->vector.displaced = Cnil; - x->vector.dim = x->vector.fillp = l; - x->vector.self.t = NULL; - x->vector.elttype = (short)aet; - } - ecl_array_allocself(x); - return(x); -} - cl_object cl_elt(cl_object x, cl_object i) { diff --git a/src/c/string.d b/src/c/string.d index fee42843a..b6aeb159c 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -25,7 +25,7 @@ typedef ecl_character (*ecl_casefun)(ecl_character, bool *); static cl_object do_make_base_string(cl_index s, ecl_base_char code) { - cl_object x = cl_alloc_simple_base_string(s); + cl_object x = ecl_alloc_simple_base_string(s); cl_index i; for (i = 0; i < s; i++) x->base_string.self[i] = code; @@ -36,7 +36,7 @@ do_make_base_string(cl_index s, ecl_base_char code) static cl_object do_make_string(cl_index s, ecl_character code) { - cl_object x = cl_alloc_simple_extended_string(s); + cl_object x = ecl_alloc_simple_extended_string(s); cl_index i; for (i = 0; i < s; i++) x->string.self[i] = code; @@ -72,51 +72,22 @@ do_make_string(cl_index s, ecl_character code) @(return x) @) -cl_object -cl_alloc_simple_base_string(cl_index length) -{ - cl_object x; - - x = ecl_alloc_object(t_base_string); - x->base_string.elttype = aet_bc; - x->base_string.flags = 0; /* no fill pointer, no adjustable */ - x->base_string.displaced = Cnil; - x->base_string.dim = (x->base_string.fillp = length); - x->base_string.self = (ecl_base_char *)ecl_alloc_atomic(length+1); - x->base_string.self[length] = x->base_string.self[0] = 0; - return x; -} - -#ifdef ECL_UNICODE -cl_object -cl_alloc_simple_extended_string(cl_index length) -{ - cl_object x; - - /* should this call si_make_vector? */ - x = ecl_alloc_object(t_string); - x->string.elttype = aet_ch; - x->string.flags = 0; /* no fill pointer, no adjustable */ - x->string.displaced = Cnil; - x->string.dim = x->string.fillp = length; - x->string.self = (ecl_character *) - ecl_alloc_align(sizeof(ecl_character)*length, - sizeof(ecl_character)); - return(x); -} -#endif - /* Make a string of a certain size, with some eading zeros to keep C happy. The string must be adjustable, to allow further growth. (See unixfsys.c for its use). */ cl_object -cl_alloc_adjustable_base_string(cl_index l) +ecl_alloc_adjustable_base_string(cl_index l) { - cl_object output = cl_alloc_simple_base_string(l); - output->base_string.fillp = 0; - output->base_string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; + cl_object output = ecl_alloc_object(t_base_string); + output->base_string.self = (ecl_base_char *)ecl_alloc_atomic(l+1); + output->base_string.self[l] = 0; + output->base_string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; + output->base_string.elttype = aet_bc; + output->base_string.displaced = Cnil; + output->base_string.dim = l; + output->base_string.fillp = 0; return output; } @@ -124,9 +95,14 @@ cl_alloc_adjustable_base_string(cl_index l) cl_object ecl_alloc_adjustable_extended_string(cl_index l) { - cl_object output = cl_alloc_simple_extended_string(l); - output->string.fillp = 0; - output->string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; + cl_index bytes = sizeof(ecl_character) * l; + cl_object output = ecl_alloc_object(t_string); + output->string.self = (ecl_character *)ecl_alloc_atomic(bytes); + output->string.flags = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE; + output->string.elttype = aet_ch; + output->string.displaced = Cnil; + output->string.dim = l; + output->string.fillp = 0; return output; } #endif @@ -156,7 +132,7 @@ make_base_string_copy(const char *s) cl_object x; cl_index l = strlen(s); - x = cl_alloc_simple_base_string(l); + x = ecl_alloc_simple_base_string(l); memcpy(x->base_string.self, s, l); return x; } @@ -208,7 +184,7 @@ si_copy_to_simple_base_string(cl_object x) #ifdef ECL_UNICODE case t_string: { cl_index index, length = x->string.fillp; - y = cl_alloc_simple_base_string(length); + y = ecl_alloc_simple_base_string(length); for (index=0; index < length; index++) { ecl_character c = x->string.self[index]; if (!BASE_CHAR_CODE_P(c)) @@ -220,7 +196,7 @@ si_copy_to_simple_base_string(cl_object x) #endif case t_base_string: { cl_index length = x->base_string.fillp; - y = cl_alloc_simple_base_string(length); + y = ecl_alloc_simple_base_string(length); memcpy(y->base_string.self, x->base_string.self, length); break; } @@ -249,16 +225,16 @@ cl_string(cl_object x) ecl_character c = CHAR_CODE(x); #ifdef ECL_UNICODE if (BASE_CHAR_CODE_P(c)) { - y = cl_alloc_simple_base_string(1); + y = ecl_alloc_simple_base_string(1); y->base_string.self[0] = c; x = y; } else { - y = cl_alloc_simple_extended_string(1); + y = ecl_alloc_simple_extended_string(1); y->string.self[0] = c; x = y; } #else - y = cl_alloc_simple_base_string(1); + y = ecl_alloc_simple_base_string(1); y->base_string.self[0] = c; x = y; break; @@ -301,12 +277,12 @@ AGAIN: x = x->symbol.name; goto AGAIN; case t_character: - y = cl_alloc_simple_extended_string(1); + y = ecl_alloc_simple_extended_string(1); y->string.self[0] = CHAR_CODE(x); break; case t_base_string: { cl_index index, len = x->base_string.dim; - y = cl_alloc_simple_extended_string(x->base_string.fillp); + y = ecl_alloc_simple_extended_string(x->base_string.fillp); for(index=0; index < len; index++) { y->string.self[index] = x->base_string.self[index]; } @@ -956,7 +932,7 @@ nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, cl_va_list ARGS) } } /* Do actual copying by recovering those strings */ - output = cl_alloc_simple_base_string(l); + output = ecl_alloc_simple_base_string(l); while (l) { cl_object s = ECL_STACK_POP_UNSAFE(the_env); size_t bytes = s->base_string.fillp; diff --git a/src/c/unixfsys.d b/src/c/unixfsys.d index cba40c04f..bfd58d283 100644 --- a/src/c/unixfsys.d +++ b/src/c/unixfsys.d @@ -121,7 +121,7 @@ current_dir(void) { cl_index size = 128; do { - output = cl_alloc_adjustable_base_string(size); + output = ecl_alloc_adjustable_base_string(size); ecl_disable_interrupts(); ok = getcwd((char*)output->base_string.self, size); ecl_enable_interrupts(); @@ -130,7 +130,7 @@ current_dir(void) { size = strlen((char*)output->base_string.self); if ((size + 1 /* / */ + 1 /* 0 */) >= output->base_string.dim) { /* Too large to host the trailing '/' */ - cl_object other = cl_alloc_adjustable_base_string(size+2); + cl_object other = ecl_alloc_adjustable_base_string(size+2); strcpy((char*)other->base_string.self, (char*)output->base_string.self); output = other; } @@ -201,7 +201,7 @@ si_readlink(cl_object filename) { cl_index size = 128, written; cl_object output, kind; do { - output = cl_alloc_adjustable_base_string(size); + output = ecl_alloc_adjustable_base_string(size); ecl_disable_interrupts(); written = readlink((char*)filename->base_string.self, (char*)output->base_string.self, size); @@ -920,7 +920,7 @@ si_get_library_pathname(void) char *buffer; HMODULE hnd; cl_index len, ep; - s = cl_alloc_adjustable_base_string(cl_core.path_max); + s = ecl_alloc_adjustable_base_string(cl_core.path_max); buffer = (char*)s->base_string.self; ecl_disable_interrupts(); hnd = GetModuleHandle("ecl.dll"); @@ -1037,13 +1037,13 @@ si_mkstemp(cl_object template) output = Cnil; } else { l = strlen(strTempFileName); - output = cl_alloc_simple_base_string(l); + output = ecl_alloc_simple_base_string(l); memcpy(output->base_string.self, strTempFileName, l); } #else template = si_coerce_to_filename(template); l = template->base_string.fillp; - output = cl_alloc_simple_base_string(l + 6); + output = ecl_alloc_simple_base_string(l + 6); memcpy(output->base_string.self, template->base_string.self, l); memcpy(output->base_string.self + l, "XXXXXX", 6); diff --git a/src/h/external.h b/src/h/external.h index 182e55cca..bb31ca21d 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -332,6 +332,7 @@ extern ECL_API cl_object ecl_aref1(cl_object v, cl_index index); extern ECL_API cl_object ecl_aset(cl_object x, cl_index index, cl_object value); extern ECL_API cl_object ecl_aset1(cl_object v, cl_index index, cl_object val); extern ECL_API void ecl_array_allocself(cl_object x); +extern ECL_API cl_object ecl_alloc_simple_vector(cl_index l, cl_elttype aet); extern ECL_API cl_elttype ecl_array_elttype(cl_object x); extern ECL_API cl_elttype ecl_symbol_to_elttype(cl_object x); extern ECL_API cl_object ecl_elttype_to_symbol(cl_elttype aet); @@ -1433,7 +1434,6 @@ extern ECL_API cl_object cl_reverse(cl_object x); extern ECL_API cl_object cl_nreverse(cl_object x); extern ECL_API cl_object cl_subseq _ARGS((cl_narg narg, cl_object sequence, cl_object start, ...)); -extern ECL_API cl_object ecl_alloc_simple_vector(cl_index l, cl_elttype aet); extern ECL_API cl_object ecl_elt(cl_object seq, cl_fixnum index); extern ECL_API cl_object ecl_elt_set(cl_object seq, cl_fixnum index, cl_object val); extern ECL_API cl_fixnum ecl_length(cl_object x); @@ -1496,8 +1496,8 @@ extern ECL_API cl_object cl_nstring_capitalize _ARGS((cl_narg narg, ...)); extern ECL_API cl_object si_base_string_concatenate _ARGS((cl_narg narg, ...)); extern ECL_API cl_object si_copy_to_simple_base_string(cl_object s); -extern ECL_API cl_object cl_alloc_simple_base_string(cl_index l); -extern ECL_API cl_object cl_alloc_adjustable_base_string(cl_index l); +#define ecl_alloc_simple_base_string(l) ecl_alloc_simple_vector((l),aet_bc) +extern ECL_API cl_object ecl_alloc_adjustable_base_string(cl_index l); extern ECL_API cl_object make_simple_base_string(char *s); #define make_constant_base_string(s) (make_simple_base_string((char *)s)) extern ECL_API cl_object make_base_string_copy(const char *s); @@ -1715,7 +1715,7 @@ extern ECL_API cl_object si_base_char_p(cl_object x); extern ECL_API cl_object si_base_string_p(cl_object x); extern ECL_API cl_object si_coerce_to_base_string(cl_object x); extern ECL_API cl_object si_coerce_to_extended_string(cl_object x); -extern ECL_API cl_object cl_alloc_simple_extended_string(cl_index l); +#define ecl_alloc_simple_extended_string(l) ecl_alloc_simple_vector((l),aet_ch) extern ECL_API cl_object ecl_alloc_adjustable_extended_string(cl_index l); #else #define si_base_char_p cl_characterp @@ -1944,7 +1944,7 @@ extern ECL_API cl_object clos_standard_instance_set _ARGS((cl_narg narg, cl_obje /* * LEGACY */ -#ifdef ECL_NO_LEGACY +#ifndef ECL_NO_LEGACY #define make_shortfloat(x) ecl_make_shortfloat(x); #define cl_def_c_function_va(sym,function) ecl_def_c_function_va(sym,function) @@ -1972,6 +1972,10 @@ extern ECL_API cl_object clos_standard_instance_set _ARGS((cl_narg narg, cl_obje /* #define big_copy _ecl_big_copy Has disappeared */ /* #define big_to_double Has disappeared */ +#define cl_alloc_simple_base_string ecl_alloc_simple_base_string +#define cl_alloc_adjustable_base_string ecl_alloc_adjustable_base_string +#define cl_alloc_simple_extended_string ecl_alloc_simple_extended_string + #endif #ifdef __cplusplus diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index b00588e8e..5c5f1e58d 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -421,7 +421,7 @@ (c-inline (foreign-string length) (t fixnum) string "{ cl_index length = #1; - cl_object output = cl_alloc_simple_base_string(length); + cl_object output = ecl_alloc_simple_base_string(length); memcpy(output->base_string.self, (#0)->foreign.data, length); @(return) = output; }"