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

The function ecl_alloc_simple_vector() is responsible now for allocation of simple strings and it uses ecl_alloc_compact_object().

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-08-29 18:53:28 +02:00
parent 8af928156c
commit 4bcd908a0a
11 changed files with 111 additions and 117 deletions
Download patch file Download diff file Expand all files Collapse all files

7
src/CHANGELOG
View file

@ -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 ***

2
src/c/all_symbols.d
View file

@ -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';

66
src/c/array.d
View file

@ -18,6 +18,7 @@
#include <limits.h>
#include <string.h>
#include <ecl/ecl.h>
#include <ecl/internal.h>
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)
{

5
src/c/big.d
View file

@ -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);

2
src/c/file.d
View file

@ -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

2
src/c/num_rand.d
View file

@ -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)

36
src/c/sequence.d
View file

@ -19,42 +19,6 @@
#include <limits.h>
#include <ecl/ecl-inl.h>
/*
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)
{

80
src/c/string.d
View file

@ -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;

12
src/c/unixfsys.d
View file

@ -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);

14
src/h/external.h
View file

@ -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

2
src/lsp/ffi.lsp
View file

@ -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;
}"