mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-11 07:20:29 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'cleanup' into 'develop'

Browse source 
this merge request introduces various cleanup fixes

See merge request embeddable-common-lisp/ecl!278
This commit is contained in:
Marius Gerbershagen 2022-12-11 09:39:08 +00:00
commit 7175e592bd
22 changed files with 520 additions and 982 deletions
Download patch file Download diff file Expand all files Collapse all files

1
src/c/all_symbols.d
View file

@ -235,7 +235,6 @@ make_this_symbol(int i, cl_object s, int code,
default: printf("%d\n", code & ~(int)3); ecl_internal_error("Unknown package code in init_all_symbols()");
}
s->symbol.t = t_symbol;
s->symbol.dynamic = 0;
#ifdef ECL_THREADS
s->symbol.binding = ECL_MISSING_SPECIAL_BINDING;
#endif

426
src/c/alloc_2.d
View file

@ -39,14 +39,9 @@ static void ecl_mark_env(struct cl_env_struct *env);
# undef GBC_BOEHM_PRECISE
# else
# include <gc/gc_typed.h>
# ifdef GBC_BOEHM_OWN_ALLOCATOR
# include <gc/private/gc_priv.h>
# endif
# define GBC_BOEHM_OWN_MARKER
# if defined(GBC_BOEHM_OWN_MARKER) || defined(GBC_BOEHM_OWN_ALLOCATOR)
static int cl_object_kind, cl_object_mark_proc_index;
static void **cl_object_free_list;
# endif
extern void GC_init_explicit_typing(void);
# endif
#endif
@ -166,10 +161,6 @@ out_of_memory(size_t requested_bytes)
return GC_MALLOC(requested_bytes);
}
#ifdef alloc_object
#undef alloc_object
#endif
static struct ecl_type_information {
size_t size;
#ifdef GBC_BOEHM_PRECISE
@ -237,58 +228,12 @@ allocate_object_typed(struct ecl_type_information *type_info)
}
#endif
#ifdef GBC_BOEHM_OWN_ALLOCATOR
#error
static cl_object
allocate_object_own(struct ecl_type_information *type_info)
{
#define TYPD_EXTRA_BYTES (sizeof(word) - EXTRA_BYTES)
#define GENERAL_MALLOC(lb,k) (void *)GC_generic_malloc(lb, k)
const cl_env_ptr the_env = ecl_process_env();
typedef void *ptr_t;
ptr_t op;
ptr_t * opp;
size_t lg, lb;
DCL_LOCK_STATE;
ecl_disable_interrupts_env(the_env);
lb = type_info->size + TYPD_EXTRA_BYTES;
if (ecl_likely(SMALL_OBJ(lb))) {
lg = GC_size_map[lb];
opp = &(cl_object_free_list[lg]);
LOCK();
if( (op = *opp) == 0 ) {
UNLOCK();
op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind);
if (0 == op) {
ecl_enable_interrupts_env(the_env);
return 0;
}
lg = GC_size_map[lb]; /* May have been uninitialized. */
} else {
*opp = obj_link(op);
obj_link(op) = 0;
GC_bytes_allocd += GRANULES_TO_BYTES(lg);
UNLOCK();
}
} else {
op = (ptr_t)GENERAL_MALLOC((word)lb, cl_object_kind);
lg = BYTES_TO_GRANULES(GC_size(op));
}
((word *)op)[GRANULES_TO_WORDS(lg) - 1] = type_info->descriptor;
((cl_object)op)->d.t = type_info->t;
ecl_enable_interrupts_env(the_env);
return (cl_object)op;
}
#endif /* GBC_BOEHM_OWN_ALLOCATOR */
#ifdef GBC_BOEHM_OWN_MARKER
static struct GC_ms_entry *
cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl,
GC_word env)
{
#if 1
cl_type t = ((cl_object)addr)->d.t;
if (ecl_likely(t > t_start && t < t_end)) {
struct ecl_type_information *info = type_info + t;
@ -306,185 +251,6 @@ cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl
}
}
}
#else
#define MAYBE_MARK2(ptr) { \
GC_word aux = (GC_word)(ptr); \
if (!(aux & 2) && \
aux >= (GC_word)GC_least_plausible_heap_addr && \
aux <= (GC_word)GC_greatest_plausible_heap_addr) \
msp = GC_mark_and_push((void*)aux, msp, msl, (void*)o); \
}
#define MAYBE_MARK(ptr) { \
GC_word aux = (GC_word)(ptr); \
if (!(aux & 2) && \
aux >= (GC_word)lpa && \
aux <= (GC_word)gpa) \
msp = GC_mark_and_push((void*)aux, msp, msl, (void*)o); \
}
cl_object o = (cl_object)addr;
const GC_word lpa = (GC_word)GC_least_plausible_heap_addr;
const GC_word gpa = (GC_word)GC_greatest_plausible_heap_addr;
switch (o->d.t) {
case t_bignum:
MAYBE_MARK(ECL_BIGNUN_LIMBS(o));
break;
case t_ratio:
MAYBE_MARK(o->ratio.num);
MAYBE_MARK(o->ratio.den);
break;
case t_complex:
MAYBE_MARK(o->gencomplex.real);
MAYBE_MARK(o->gencomplex.imag);
break;
case t_symbol:
MAYBE_MARK(o->symbol.hpack);
MAYBE_MARK(o->symbol.name);
MAYBE_MARK(o->symbol.plist);
MAYBE_MARK(o->symbol.gfdef);
MAYBE_MARK(o->symbol.value);
break;
case t_package:
MAYBE_MARK(o->pack.external);
MAYBE_MARK(o->pack.internal);
MAYBE_MARK(o->pack.usedby);
MAYBE_MARK(o->pack.uses);
MAYBE_MARK(o->pack.shadowings);
MAYBE_MARK(o->pack.nicknames);
MAYBE_MARK(o->pack.name);
break;
case t_hashtable:
MAYBE_MARK(o->hash.threshold);
MAYBE_MARK(o->hash.rehash_size);
MAYBE_MARK(o->hash.data);
break;
case t_array:
MAYBE_MARK(o->array.dims);
case t_vector:
# ifdef ECL_UNICODE
case t_string:
# endif
case t_base_string:
case t_bitvector:
MAYBE_MARK(o->vector.self.t);
MAYBE_MARK(o->vector.displaced);
break;
case t_stream:
MAYBE_MARK(o->stream.format_table);
MAYBE_MARK(o->stream.format);
MAYBE_MARK(o->stream.buffer);
MAYBE_MARK(o->stream.byte_stack);
MAYBE_MARK(o->stream.object1);
MAYBE_MARK(o->stream.object0);
MAYBE_MARK(o->stream.ops);
break;
case t_random:
MAYBE_MARK(o->random.value);
break;
case t_readtable:
# ifdef ECL_UNICODE
MAYBE_MARK(o->readtable.hash);
# endif
MAYBE_MARK(o->readtable.table);
break;
case t_pathname:
MAYBE_MARK(o->pathname.version);
MAYBE_MARK(o->pathname.type);
MAYBE_MARK(o->pathname.name);
MAYBE_MARK(o->pathname.directory);
MAYBE_MARK(o->pathname.device);
MAYBE_MARK(o->pathname.host);
break;
case t_bytecodes:
MAYBE_MARK(o->bytecodes.file_position);
MAYBE_MARK(o->bytecodes.file);
MAYBE_MARK(o->bytecodes.data);
MAYBE_MARK(o->bytecodes.code);
MAYBE_MARK(o->bytecodes.definition);
MAYBE_MARK(o->bytecodes.name);
break;
case t_bclosure:
MAYBE_MARK(o->bclosure.lex);
MAYBE_MARK(o->bclosure.code);
break;
case t_cfun:
MAYBE_MARK(o->cfun.file_position);
MAYBE_MARK(o->cfun.file);
MAYBE_MARK(o->cfun.block);
MAYBE_MARK(o->cfun.name);
break;
case t_cfunfixed:
MAYBE_MARK(o->cfunfixed.file_position);
MAYBE_MARK(o->cfunfixed.file);
MAYBE_MARK(o->cfunfixed.block);
MAYBE_MARK(o->cfunfixed.name);
break;
case t_cclosure:
MAYBE_MARK(o->cclosure.file_position);
MAYBE_MARK(o->cclosure.file);
MAYBE_MARK(o->cclosure.block);
MAYBE_MARK(o->cclosure.env);
break;
case t_instance:
MAYBE_MARK(o->instance.slots);
MAYBE_MARK(o->instance.slotds);
MAYBE_MARK(o->instance.clas);
break;
# ifdef ECL_THREADS
case t_process:
MAYBE_MARK(o->process.queue_record);
MAYBE_MARK(o->process.woken_up);
MAYBE_MARK(o->process.exit_values);
MAYBE_MARK(o->process.parent);
MAYBE_MARK(o->process.initial_bindings);
MAYBE_MARK(o->process.interrupt);
MAYBE_MARK(o->process.args);
MAYBE_MARK(o->process.function);
MAYBE_MARK(o->process.name);
if (o->process.env && o->process.env != ECL_NIL)
ecl_mark_env(o->process.env);
break;
case t_lock:
MAYBE_MARK(o->lock.owner);
MAYBE_MARK(o->lock.name);
break;
case t_condition_variable:
break;
case t_rwlock:
MAYBE_MARK(o->rwlock.name);
break;
case t_semaphore:
MAYBE_MARK(o->semaphore.name);
break;
case t_barrier:
MAYBE_MARK(o->barrier.name);
break;
case t_mailbox:
MAYBE_MARK(o->mailbox.data);
MAYBE_MARK(o->mailbox.name);
break;
# endif
case t_codeblock:
MAYBE_MARK(o->cblock.error);
MAYBE_MARK(o->cblock.source);
MAYBE_MARK(o->cblock.links);
MAYBE_MARK(o->cblock.name);
MAYBE_MARK(o->cblock.next);
MAYBE_MARK(o->cblock.temp_data);
MAYBE_MARK(o->cblock.data);
break;
case t_foreign:
MAYBE_MARK(o->foreign.tag);
MAYBE_MARK(o->foreign.data);
break;
case t_frame:
MAYBE_MARK(o->frame.env);
MAYBE_MARK(o->frame.base);
MAYBE_MARK(o->frame.stack);
break;
default:
break;
}
#endif
return msp;
}
@ -621,26 +387,6 @@ ecl_cons(cl_object a, cl_object d)
#endif
}
cl_object
ecl_list1(cl_object a)
{
const cl_env_ptr the_env = ecl_process_env();
struct ecl_cons *obj;
ecl_disable_interrupts_env(the_env);
obj = GC_MALLOC(sizeof(struct ecl_cons));
ecl_enable_interrupts_env(the_env);
#ifdef ECL_SMALL_CONS
obj->car = a;
obj->cdr = ECL_NIL;
return ECL_PTR_CONS(obj);
#else
obj->t = t_list;
obj->car = a;
obj->cdr = ECL_NIL;
return (cl_object)obj;
#endif
}
cl_object
ecl_alloc_instance(cl_index slots)
{
@ -725,12 +471,6 @@ ecl_dealloc(void *ptr)
ecl_enable_interrupts_env(the_env);
}
static int alloc_initialized = FALSE;
extern void (*GC_push_other_roots)();
static void (*old_GC_push_other_roots)();
static void stacks_scanner();
#ifdef GBC_BOEHM_PRECISE
static cl_index
to_bitmap(void *x, void *y)
@ -743,80 +483,17 @@ to_bitmap(void *x, void *y)
}
#endif
void
init_alloc(void)
void init_type_info (void)
{
#ifdef GBC_BOEHM_PRECISE
union cl_lispunion o;
struct ecl_cons c;
#endif
int i;
if (alloc_initialized) return;
alloc_initialized = TRUE;
/*
* Garbage collector restrictions: we set up the garbage collector
* library to work as follows
*
* 1) The garbage collector shall not scan shared libraries
* explicitely.
* 2) We only detect objects that are referenced by a pointer to
* the begining or to the first byte.
* 3) Out of the incremental garbage collector, we only use the
* generational component.
*/
GC_set_no_dls(1);
GC_set_all_interior_pointers(0);
GC_set_time_limit(GC_TIME_UNLIMITED);
GC_init();
#ifdef ECL_THREADS
# if GC_VERSION_MAJOR > 7 || GC_VERSION_MINOR > 1
GC_allow_register_threads();
# endif
#endif
if (ecl_option_values[ECL_OPT_INCREMENTAL_GC]) {
GC_enable_incremental();
}
GC_register_displacement(1);
#ifdef GBC_BOEHM_PRECISE
GC_init_explicit_typing();
#endif
GC_clear_roots();
GC_disable();
#ifdef GBC_BOEHM_PRECISE
# ifdef GBC_BOEHM_OWN_ALLOCATOR
cl_object_free_list = (void **)GC_new_free_list_inner();
cl_object_kind = GC_new_kind_inner(cl_object_free_list,
(((word)WORDS_TO_BYTES(-1)) | GC_DS_PER_OBJECT),
TRUE, TRUE);
# else
# ifdef GBC_BOEHM_OWN_MARKER
cl_object_free_list = (void **)GC_new_free_list_inner();
cl_object_mark_proc_index = GC_new_proc((GC_mark_proc)cl_object_mark_proc);
cl_object_kind = GC_new_kind_inner(cl_object_free_list,
GC_MAKE_PROC(cl_object_mark_proc_index, 0),
FALSE, TRUE);
# endif
# endif
#endif /* !GBC_BOEHM_PRECISE */
GC_set_max_heap_size(cl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]);
/* Save some memory for the case we get tight. */
if (cl_core.max_heap_size == 0) {
cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA];
cl_core.safety_region = ecl_alloc_atomic_unprotected(size);
} else if (cl_core.safety_region) {
cl_core.safety_region = 0;
}
#define init_tm(/* cl_type */ type, \
/* char* */ name, \
/* cl_index */ object_size, \
/* cl_index */ maxpage) { \
type_info[type].size = (object_size); \
if ((maxpage) == 0) { \
type_info[type].allocator = allocate_object_atomic; \
} \
#define init_tm(/* cl_type */ type, \
/* char* */ name, \
/* cl_index */ object_size, \
/* cl_index */ maxpage) { \
type_info[type].size = (object_size); \
if ((maxpage) == 0) { \
type_info[type].allocator = allocate_object_atomic; \
} \
}
for (i = 0; i < t_end; i++) {
type_info[i].t = i;
@ -998,8 +675,7 @@ init_alloc(void)
to_bitmap(&o, &(o.process.initial_bindings)) |
to_bitmap(&o, &(o.process.parent)) |
to_bitmap(&o, &(o.process.exit_values)) |
to_bitmap(&o, &(o.process.woken_up)) |
to_bitmap(&o, &(o.process.queue_record));
to_bitmap(&o, &(o.process.woken_up));
type_info[t_lock].descriptor =
to_bitmap(&o, &(o.lock.name)) |
to_bitmap(&o, &(o.lock.owner));
@ -1058,6 +734,69 @@ init_alloc(void)
type_info[i].descriptor = descriptor;
}
#endif /* GBC_BOEHM_PRECISE */
}
extern void (*GC_push_other_roots)();
static void (*old_GC_push_other_roots)();
static void stacks_scanner();
static int alloc_initialized = FALSE;
void
init_alloc(void)
{
if (alloc_initialized) return;
alloc_initialized = TRUE;
init_type_info();
/*
* Garbage collector restrictions: we set up the garbage collector
* library to work as follows
*
* 1) The garbage collector shall not scan shared libraries
* explicitely.
* 2) We only detect objects that are referenced by a pointer to
* the begining or to the first byte.
* 3) Out of the incremental garbage collector, we only use the
* generational component.
*/
GC_set_no_dls(1);
GC_set_all_interior_pointers(0);
GC_set_time_limit(GC_TIME_UNLIMITED);
GC_init();
#ifdef ECL_THREADS
# if GC_VERSION_MAJOR > 7 || GC_VERSION_MINOR > 1
GC_allow_register_threads();
# endif
#endif
if (ecl_option_values[ECL_OPT_INCREMENTAL_GC]) {
GC_enable_incremental();
}
GC_register_displacement(1);
#ifdef GBC_BOEHM_PRECISE
GC_init_explicit_typing();
#endif
GC_clear_roots();
GC_disable();
#ifdef GBC_BOEHM_PRECISE
# ifdef GBC_BOEHM_OWN_MARKER
cl_object_free_list = (void **)GC_new_free_list_inner();
cl_object_mark_proc_index = GC_new_proc((GC_mark_proc)cl_object_mark_proc);
cl_object_kind = GC_new_kind_inner(cl_object_free_list,
GC_MAKE_PROC(cl_object_mark_proc_index, 0),
FALSE, TRUE);
# endif
#endif /* !GBC_BOEHM_PRECISE */
GC_set_max_heap_size(cl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]);
/* Save some memory for the case we get tight. */
if (cl_core.max_heap_size == 0) {
cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA];
cl_core.safety_region = ecl_alloc_atomic_unprotected(size);
} else if (cl_core.safety_region) {
cl_core.safety_region = 0;
}
old_GC_push_other_roots = GC_push_other_roots;
GC_push_other_roots = stacks_scanner;
GC_old_start_callback = GC_get_start_callback();
@ -1504,7 +1243,7 @@ si_gc_dump()
* WEAK POINTERS
*/
static cl_object
cl_object
ecl_alloc_weak_pointer(cl_object o)
{
const cl_env_ptr the_env = ecl_process_env();
@ -1521,6 +1260,12 @@ ecl_alloc_weak_pointer(cl_object o)
return (cl_object)obj;
}
static cl_object
ecl_weak_pointer_value(cl_object o)
{
return ecl_weak_pointer(o);
}
cl_object
si_make_weak_pointer(cl_object o)
{
@ -1528,24 +1273,19 @@ si_make_weak_pointer(cl_object o)
@(return pointer);
}
static cl_object
ecl_weak_pointer_value(cl_object o)
{
return o->weak.value;
}
cl_object
si_weak_pointer_value(cl_object o)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object value;
if (ecl_unlikely(ecl_t_of(o) != t_weak_pointer))
FEwrong_type_only_arg(@[ext::weak-pointer-value], o,
@[ext::weak-pointer]);
value = (cl_object)GC_call_with_alloc_lock((GC_fn_type)ecl_weak_pointer_value, o);
if (value) {
@(return value ECL_T);
ecl_return2(the_env, value, ECL_T);
} else {
@(return ECL_NIL ECL_NIL);
ecl_return2(the_env, ECL_NIL, ECL_NIL);
}
}

20
src/c/big.d
View file

@ -628,6 +628,26 @@ _ecl_big_boole_operator(int op)
return bignum_operations[op];
}
void
ecl_init_bignum_registers(cl_env_ptr env)
{
int i;
for (i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) {
cl_object x = ecl_alloc_object(t_bignum);
_ecl_big_init2(x, ECL_BIG_REGISTER_SIZE);
env->big_register[i] = x;
}
}
void
ecl_clear_bignum_registers(cl_env_ptr env)
{
int i;
for (i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) {
_ecl_big_clear(env->big_register[i]);
}
}
void
init_big()
{

4
src/c/cinit.d
View file

@ -65,7 +65,7 @@ clos_std_compute_applicable_methods(cl_object gf, cl_object arglist)
extern cl_object
si_bind_simple_restarts(cl_object tag, cl_object names)
{
if (ECL_SYM_FUN(@'si::bind-simple-restarts') != Cnil)
if (ECL_SYM_FUN(@'si::bind-simple-restarts') != ECL_NIL)
return _ecl_funcall3(@'si::bind-simple-restarts', tag, names);
else
return ECL_SYM_VAL(ecl_process_env(), @'si::*restart-clusters*');
@ -74,7 +74,7 @@ si_bind_simple_restarts(cl_object tag, cl_object names)
extern cl_object
si_bind_simple_handlers(cl_object tag, cl_object names)
{
if (ECL_SYM_FUN(@'si::bind-simple-handlers') != Cnil)
if (ECL_SYM_FUN(@'si::bind-simple-handlers') != ECL_NIL)
return _ecl_funcall3(@'si::bind-simple-handlers', tag, names);
else
return ECL_SYM_VAL(ecl_process_env(), @'si::*handler-clusters*');

0
src/c/dpp.c Executable file → Normal file
View file

12
src/c/error.d
View file

@ -50,8 +50,7 @@ ecl_internal_error(const char *s)
int saved_errno = errno;
fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s);
if (saved_errno) {
fprintf(stderr, " [%d: %s]\n", saved_errno,
strerror(saved_errno));
fprintf(stderr, " [%d: %s]\n", saved_errno, strerror(saved_errno));
}
fflush(stderr);
_ecl_dump_c_backtrace();
@ -68,19 +67,14 @@ ecl_thread_internal_error(const char *s)
int saved_errno = errno;
fprintf(stderr, "\nInternal thread error in:\n%s\n", s);
if (saved_errno) {
fprintf(stderr, " [%d: %s]\n", saved_errno,
strerror(saved_errno));
fprintf(stderr, " [%d: %s]\n", saved_errno, strerror(saved_errno));
}
_ecl_dump_c_backtrace();
fprintf(stderr,
"\nDid you forget to call `ecl_import_current_thread'?\n"
"Exitting thread.\n");
fflush(stderr);
#ifdef ECL_WINDOWS_THREADS
ExitThread(0);
#else
pthread_exit(NULL);
#endif
ecl_thread_exit();
}
#endif

76
src/c/file.d Executable file → Normal file
View file

@ -5628,39 +5628,10 @@ ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists,
* BACKEND
*/
#if defined(ECL_MS_WINDOWS_HOST)
static int
file_listen(cl_object stream, int fileno)
{
#if !defined(ECL_MS_WINDOWS_HOST)
# if defined(HAVE_SELECT)
fd_set fds;
int retv;
struct timeval tv = { 0, 0 };
/*
* Note that the following code is fragile. If the file is closed (/dev/null)
* then select() may return 1 (at least on OS X), so that we return a flag
* saying characters are available but will find none to read. See also the
* code in cl_clear_input().
*/
FD_ZERO(&fds);
FD_SET(fileno, &fds);
retv = select(fileno + 1, &fds, NULL, NULL, &tv);
if (ecl_unlikely(retv < 0))
file_libc_error(@[stream-error], stream, "Error while listening to stream.", 0);
/* XXX: for FIFO there should be also peek-byte (not implemented and peek-char
doesn't work for binary streams). */
else if ((retv > 0) /* && (generic_peek_byte(stream) != EOF) */)
return ECL_LISTEN_AVAILABLE;
else
return ECL_LISTEN_NO_CHAR;
# elif defined(FIONREAD)
{
long c = 0;
ioctl(fileno, FIONREAD, &c);
return (c > 0)? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR;
}
# endif
#else
HANDLE hnd = (HANDLE)_get_osfhandle(fileno);
switch (GetFileType(hnd)) {
case FILE_TYPE_CHAR: {
@ -5690,8 +5661,9 @@ file_listen(cl_object stream, int fileno)
}
}
return ECL_LISTEN_NO_CHAR;
} else
} else {
FEwin32_error("GetNumberOfConsoleInputEvents() failed", 0);
}
break;
}
case FILE_TYPE_DISK:
@ -5711,9 +5683,45 @@ file_listen(cl_object stream, int fileno)
FEerror("Unsupported Windows file type: ~A", 1, ecl_make_fixnum(GetFileType(hnd)));
break;
}
#endif
return -3;
return ECL_LISTEN_FALLBACK;
}
#else
static int
file_listen(cl_object stream, int fileno)
{
# if defined(HAVE_SELECT)
fd_set fds;
int retv;
struct timeval tv = { 0, 0 };
/*
* Note that the following code is fragile. If the file is closed (/dev/null)
* then select() may return 1 (at least on OS X), so that we return a flag
* saying characters are available but will find none to read. See also the
* code in cl_clear_input().
*/
FD_ZERO(&fds);
FD_SET(fileno, &fds);
retv = select(fileno + 1, &fds, NULL, NULL, &tv);
if (ecl_unlikely(retv < 0))
file_libc_error(@[stream-error], stream, "Error while listening to stream.", 0);
/* XXX: for FIFO there should be also peek-byte (not implemented and peek-char
doesn't work for binary streams). */
else if ((retv > 0) /* && (generic_peek_char(stream) != EOF) */) {
return ECL_LISTEN_AVAILABLE;
}
else {
return ECL_LISTEN_NO_CHAR;
}
# elif defined(FIONREAD)
{
long c = 0;
ioctl(fileno, FIONREAD, &c);
return (c > 0)? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR;
}
# endif
return ECL_LISTEN_FALLBACK;
}
#endif
static int
flisten(cl_object stream, FILE *fp)
@ -5726,7 +5734,7 @@ flisten(cl_object stream, FILE *fp)
return ECL_LISTEN_AVAILABLE;
#endif
aux = file_listen(stream, fileno(fp));
if (aux != -3)
if (aux != ECL_LISTEN_FALLBACK)
return aux;
/* This code is portable, and implements the expected behavior for regular files.
It will fail on noninteractive streams. */

144
src/c/interpreter.d
View file

@ -19,150 +19,6 @@
#include <ecl/internal.h>
#include <ecl/stack-resize.h>
/* -------------------- INTERPRETER STACK -------------------- */
cl_object *
ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size)
{
cl_index top = env->stack_top - env->stack;
cl_object *new_stack, *old_stack;
cl_index safety_area = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA];
cl_index new_size = tentative_new_size + 2*safety_area;
/* Round to page size */
new_size = ((new_size + LISP_PAGESIZE - 1) / LISP_PAGESIZE) * LISP_PAGESIZE;
if (ecl_unlikely(top > new_size)) {
FEerror("Internal error: cannot shrink stack below stack top.",0);
}
old_stack = env->stack;
new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object));
ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env);
memcpy(new_stack, old_stack, env->stack_size * sizeof(cl_object));
env->stack_size = new_size;
env->stack_limit_size = new_size - 2*safety_area;
env->stack = new_stack;
env->stack_top = env->stack + top;
env->stack_limit = env->stack + (new_size - 2*safety_area);
/* A stack always has at least one element. This is assumed by cl__va_start
* and friends, which take a sp=0 to have no arguments.
*/
if (top == 0) {
*(env->stack_top++) = ecl_make_fixnum(0);
}
ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env);
return env->stack_top;
}
void
FEstack_underflow(void)
{
FEerror("Internal error: stack underflow.",0);
}
void
FEstack_advance(void)
{
FEerror("Internal error: stack advance beyond current point.",0);
}
cl_object *
ecl_stack_grow(cl_env_ptr env)
{
return ecl_stack_set_size(env, env->stack_size + env->stack_size / 2);
}
cl_index
ecl_stack_push_values(cl_env_ptr env) {
cl_index i = env->nvalues;
cl_object *b = env->stack_top;
cl_object *p = b + i;
if (p >= env->stack_limit) {
b = ecl_stack_grow(env);
p = b + i;
}
env->stack_top = p;
memcpy(b, env->values, i * sizeof(cl_object));
return i;
}
void
ecl_stack_pop_values(cl_env_ptr env, cl_index n) {
cl_object *p = env->stack_top - n;
if (ecl_unlikely(p < env->stack))
FEstack_underflow();
env->nvalues = n;
env->stack_top = p;
memcpy(env->values, p, n * sizeof(cl_object));
}
cl_object
ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size)
{
cl_object *base = env->stack_top;
if (size) {
if ((env->stack_limit - base) < size) {
base = ecl_stack_set_size(env, env->stack_size + size);
}
}
f->frame.t = t_frame;
f->frame.stack = env->stack;
f->frame.base = base;
f->frame.size = size;
f->frame.env = env;
env->stack_top = (base + size);
return f;
}
void
ecl_stack_frame_push(cl_object f, cl_object o)
{
cl_env_ptr env = f->frame.env;
cl_object *top = env->stack_top;
if (top >= env->stack_limit) {
top = ecl_stack_grow(env);
}
env->stack_top = ++top;
*(top-1) = o;
f->frame.base = top - (++(f->frame.size));
f->frame.stack = env->stack;
}
void
ecl_stack_frame_push_values(cl_object f)
{
cl_env_ptr env = f->frame.env;
ecl_stack_push_values(env);
f->frame.base = env->stack_top - (f->frame.size += env->nvalues);
f->frame.stack = env->stack;
}
cl_object
ecl_stack_frame_pop_values(cl_object f)
{
cl_env_ptr env = f->frame.env;
cl_index n = f->frame.size % ECL_MULTIPLE_VALUES_LIMIT;
cl_object o;
env->nvalues = n;
env->values[0] = o = ECL_NIL;
while (n--) {
env->values[n] = o = f->frame.base[n];
}
return o;
}
void
ecl_stack_frame_close(cl_object f)
{
if (f->frame.stack) {
ECL_STACK_SET_INDEX(f->frame.env, f->frame.base - f->frame.stack);
}
}
/* ------------------------------ LEXICAL ENV. ------------------------------ */
/*
* A lexical environment is a list of pairs, each one containing

111
src/c/main.d Executable file → Normal file
View file

@ -130,72 +130,71 @@ ecl_set_option(int option, cl_fixnum value)
}
}
void
ecl_init_bignum_registers(cl_env_ptr env)
static void
init_env_mp(cl_env_ptr env)
{
int i;
for (i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) {
cl_object x = ecl_alloc_object(t_bignum);
_ecl_big_init2(x, ECL_BIG_REGISTER_SIZE);
env->big_register[i] = x;
}
}
void
ecl_clear_bignum_registers(cl_env_ptr env)
{
int i;
for (i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) {
_ecl_big_clear(env->big_register[i]);
}
}
void
ecl_init_env(cl_env_ptr env)
{
env->c_env = NULL;
#if defined(ECL_THREADS)
env->cleanup = 0;
#else
env->own_process = ECL_NIL;
#endif
env->string_pool = ECL_NIL;
}
env->stack = NULL;
env->stack_top = NULL;
env->stack_limit = NULL;
env->stack_size = 0;
ecl_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]);
#if !defined(ECL_CMU_FORMAT)
env->fmt_aux_stream = ecl_make_string_output_stream(64, 1);
static void
init_env_int(cl_env_ptr env)
{
env->interrupt_struct = ecl_alloc(sizeof(*env->interrupt_struct));
env->interrupt_struct->pending_interrupt = ECL_NIL;
#ifdef ECL_THREADS
ecl_mutex_init(&env->interrupt_struct->signal_queue_lock, FALSE);
#endif
{
int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE];
env->interrupt_struct->signal_queue = cl_make_list(1, ecl_make_fixnum(size));
}
env->fault_address = env;
env->trap_fpe_bits = 0;
}
static void
init_env_ffi(cl_env_ptr env)
{
#ifdef HAVE_LIBFFI
env->ffi_args_limit = 0;
env->ffi_types = 0;
env->ffi_values = 0;
env->ffi_values_ptrs = 0;
#endif
}
env->method_cache = ecl_make_cache(64, 4096);
env->slot_cache = ecl_make_cache(3, 4096);
env->interrupt_struct = ecl_alloc(sizeof(*env->interrupt_struct));
env->interrupt_struct->pending_interrupt = ECL_NIL;
ecl_mutex_init(&env->interrupt_struct->signal_queue_lock, FALSE);
{
int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE];
env->interrupt_struct->signal_queue = cl_make_list(1, ecl_make_fixnum(size));
}
init_stacks(env);
ecl_init_bignum_registers(env);
env->trap_fpe_bits = 0;
static void
init_env_aux(cl_env_ptr env)
{
/* Reader */
env->string_pool = ECL_NIL;
env->packages_to_be_created = ECL_NIL;
env->packages_to_be_created_p = ECL_NIL;
env->fault_address = env;
/* Format (written in C) */
#if !defined(ECL_CMU_FORMAT)
env->fmt_aux_stream = ecl_make_string_output_stream(64, 1);
#endif
/* Bignum arithmetic */
ecl_init_bignum_registers(env);
/* Bytecodes compiler environment */
env->c_env = NULL;
/* CLOS caches */
env->method_cache = ecl_make_cache(64, 4096);
env->slot_cache = ecl_make_cache(3, 4096);
}
void
ecl_init_env(cl_env_ptr env)
{
init_env_mp(env);
init_env_int(env);
init_env_aux(env);
init_env_ffi(env);
init_stacks(env);
}
void
@ -208,7 +207,9 @@ _ecl_dealloc_env(cl_env_ptr env)
* a lisp environment set up -- the allocator assumes one -- and we
* may have already cleaned up the value of ecl_process_env()
*/
#ifdef ECL_THREADS
ecl_mutex_destroy(&env->interrupt_struct->signal_queue_lock);
#endif
#if defined(ECL_USE_MPROTECT)
if (munmap(env, sizeof(*env)))
ecl_internal_error("Unable to deallocate environment structure.");
@ -385,7 +386,6 @@ struct cl_core_struct cl_core = {
.error_output = ECL_NIL,
.standard_readtable = ECL_NIL,
.dispatch_reader = ECL_NIL,
.default_dispatch_macro = ECL_NIL,
.char_names = ECL_NIL,
.null_string = (cl_object)&str_empty_data,
@ -499,18 +499,13 @@ cl_boot(int argc, char **argv)
init_alloc();
GC_disable();
env = _ecl_alloc_env(0);
#ifdef ECL_THREADS
init_threads(env);
#else
cl_env_p = env;
#endif
/*
* 1) Initialize symbols and packages
*/
ECL_NIL_SYMBOL->symbol.t = t_symbol;
ECL_NIL_SYMBOL->symbol.dynamic = 0;
ECL_NIL_SYMBOL->symbol.value = ECL_NIL;
ECL_NIL_SYMBOL->symbol.name = str_NIL;
ECL_NIL_SYMBOL->symbol.gfdef = ECL_NIL;
@ -523,7 +518,6 @@ cl_boot(int argc, char **argv)
cl_num_symbols_in_core=1;
ECL_T->symbol.t = (short)t_symbol;
ECL_T->symbol.dynamic = 0;
ECL_T->symbol.value = ECL_T;
ECL_T->symbol.name = str_T;
ECL_T->symbol.gfdef = ECL_NIL;
@ -541,8 +535,6 @@ cl_boot(int argc, char **argv)
cl_core.path_max = MAXPATHLEN;
#endif
env->packages_to_be_created = ECL_NIL;
#ifdef ECL_THREADS
env->bindings_array = si_make_vector(ECL_T, ecl_make_fixnum(1024),
ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL);
@ -626,10 +618,7 @@ cl_boot(int argc, char **argv)
/* These must come _after_ the packages and NIL/T have been created */
init_all_symbols();
#if !defined(GBC_BOEHM)
/* We need this because a lot of stuff is to be created */
init_GC();
#endif
GC_enable();
/*

4
src/c/pathname.d
View file

@ -525,7 +525,7 @@ ecl_logical_hostname_p(cl_object host)
{
if (!ecl_stringp(host))
return FALSE;
return !Null(@assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal'));
return !Null(ecl_assqlp(host, cl_core.pathname_translations));
}
/*
@ -1559,7 +1559,7 @@ coerce_to_from_pathname(cl_object x, cl_object host)
FEerror("Wrong host syntax ~S", 1, host);
}
/* Find its translation list */
pair = @assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal');
pair = ecl_assqlp(host, cl_core.pathname_translations);
if (set == OBJNULL) {
@(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair)));
}

45
src/c/read.d
View file

@ -257,8 +257,7 @@ ecl_read_object_with_delimiter(cl_object in, int delimiter, int flags,
*/
cl_object name = cl_copy_seq(token);
unlikely_if (Null(the_env->packages_to_be_created_p)) {
FEerror("There is no package with the name ~A.",
1, name);
FEerror("There is no package with the name ~A.", 1, name);
}
p = _ecl_package_to_be_created(the_env, name);
}
@ -307,8 +306,7 @@ ecl_read_object_with_delimiter(cl_object in, int delimiter, int flags,
break;
}
unlikely_if (ecl_invalid_character_p(c) && !suppress) {
FEreader_error("Found invalid character ~:C", in,
1, ECL_CODE_CHAR(c));
FEreader_error("Found invalid character ~:C", in, 1, ECL_CODE_CHAR(c));
}
if (read_case != ecl_case_preserve) {
if (ecl_upper_case_p(c)) {
@ -562,8 +560,7 @@ dispatch_reader_fun(cl_object in, cl_object dc)
int c = ecl_char_code(dc);
ecl_readtable_get(readtable, c, &dispatch_table);
unlikely_if (!ECL_HASH_TABLE_P(dispatch_table))
FEreader_error("~C is not a dispatching macro character",
in, 1, dc);
FEreader_error("~C is not a dispatching macro character", in, 1, dc);
return dispatch_macro_character(dispatch_table, in, c, TRUE);
}
@ -615,7 +612,7 @@ single_quote_reader(cl_object in, cl_object c)
}
static cl_object
void_reader(cl_object in, cl_object c)
void_reader3(cl_object in, cl_object c, cl_object f)
{
/* no result */
@(return);
@ -1101,9 +1098,6 @@ sharp_R_reader(cl_object in, cl_object c, cl_object d)
@(return (read_number(in, radix, ECL_CODE_CHAR('R'))));
}
#define sharp_A_reader void_reader
#define sharp_S_reader void_reader
static cl_object
sharp_eq_reader(cl_object in, cl_object c, cl_object d)
{
@ -1281,11 +1275,8 @@ patch_sharp(const cl_env_ptr the_env, cl_object x)
}
}
#define sharp_plus_reader void_reader
#define sharp_minus_reader void_reader
#define sharp_less_than_reader void_reader
#define sharp_whitespace_reader void_reader
#define sharp_right_parenthesis_reader void_reader
#define sharp_plus_reader void_reader3
#define sharp_minus_reader void_reader3
static cl_object
sharp_vertical_bar_reader(cl_object in, cl_object ch, cl_object d)
@ -1317,12 +1308,6 @@ sharp_vertical_bar_reader(cl_object in, cl_object ch, cl_object d)
@(return);
}
static cl_object
default_dispatch_macro_fun(cl_object in, cl_object c, cl_object d)
{
FEreader_error("No dispatch function defined for character ~s.", in, 1, c);
}
/*
#P" ... " returns the pathname with namestring ... .
*/
@ -1423,8 +1408,7 @@ ecl_current_readtable(void)
r = ECL_SYM_VAL(the_env, @'*readtable*');
unlikely_if (!ECL_READTABLEP(r)) {
ECL_SETQ(the_env, @'*readtable*', cl_core.standard_readtable);
FEerror("The value of *READTABLE*, ~S, was not a readtable.",
1, r);
FEerror("The value of *READTABLE*, ~S, was not a readtable.", 1, r);
}
return r;
}
@ -1790,9 +1774,7 @@ cl_readtable_case(cl_object r)
static void
error_locked_readtable(cl_object r)
{
cl_error(2,
@"Cannot modify locked readtable ~A.",
r);
cl_error(2, @"Cannot modify locked readtable ~A.", r);
}
cl_object
@ -2077,8 +2059,6 @@ init_read(void)
make_cf2(backquote_reader));
ecl_readtable_set(r, '|', cat_multiple_escape, ECL_NIL);
cl_core.default_dispatch_macro = make_cf3(default_dispatch_macro_fun);
cl_make_dispatch_macro_character(3, ECL_CODE_CHAR('#'),
ECL_T /* non terminating */, r);
@ -2375,13 +2355,11 @@ ecl_init_module(cl_object block, void (*entry_point)(cl_object))
{
unlikely_if (block->cblock.data_text == NULL) {
unlikely_if (len > 0)
FEreader_error("Not enough data while loading"
"binary file", in, 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);
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));
}
@ -2411,8 +2389,7 @@ ecl_init_module(cl_object block, void (*entry_point)(cl_object))
}
ecl_bds_unwind(env, bds_ndx);
unlikely_if (i < len)
FEreader_error("Not enough data while loading"
"binary file", in, 0);
FEreader_error("Not enough data while loading binary file", in, 0);
cl_close(1,in);
in = OBJNULL;
#endif

214
src/c/stacks.d
View file

@ -22,7 +22,7 @@
#include <ecl/internal.h>
#include <ecl/stack-resize.h>
/************************ C STACK ***************************/
/* ------------------------- C STACK ---------------------------------- */
static void
cs_set_size(cl_env_ptr env, cl_index new_size)
@ -133,8 +133,151 @@ ecl_cs_set_org(cl_env_ptr env)
cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]);
}
/* ------------------------- LISP STACK ------------------------------- */
/********************* BINDING STACK ************************/
cl_object *
ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size)
{
cl_index top = env->stack_top - env->stack;
cl_object *new_stack, *old_stack;
cl_index safety_area = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA];
cl_index new_size = tentative_new_size + 2*safety_area;
/* Round to page size */
new_size = ((new_size + LISP_PAGESIZE - 1) / LISP_PAGESIZE) * LISP_PAGESIZE;
if (ecl_unlikely(top > new_size)) {
FEerror("Internal error: cannot shrink stack below stack top.",0);
}
old_stack = env->stack;
new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object));
ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env);
memcpy(new_stack, old_stack, env->stack_size * sizeof(cl_object));
env->stack_size = new_size;
env->stack_limit_size = new_size - 2*safety_area;
env->stack = new_stack;
env->stack_top = env->stack + top;
env->stack_limit = env->stack + (new_size - 2*safety_area);
/* A stack always has at least one element. This is assumed by cl__va_start
* and friends, which take a sp=0 to have no arguments.
*/
if (top == 0) {
*(env->stack_top++) = ecl_make_fixnum(0);
}
ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env);
return env->stack_top;
}
void
FEstack_underflow(void)
{
FEerror("Internal error: stack underflow.",0);
}
void
FEstack_advance(void)
{
FEerror("Internal error: stack advance beyond current point.",0);
}
cl_object *
ecl_stack_grow(cl_env_ptr env)
{
return ecl_stack_set_size(env, env->stack_size + env->stack_size / 2);
}
cl_index
ecl_stack_push_values(cl_env_ptr env) {
cl_index i = env->nvalues;
cl_object *b = env->stack_top;
cl_object *p = b + i;
if (p >= env->stack_limit) {
b = ecl_stack_grow(env);
p = b + i;
}
env->stack_top = p;
memcpy(b, env->values, i * sizeof(cl_object));
return i;
}
void
ecl_stack_pop_values(cl_env_ptr env, cl_index n) {
cl_object *p = env->stack_top - n;
if (ecl_unlikely(p < env->stack))
FEstack_underflow();
env->nvalues = n;
env->stack_top = p;
memcpy(env->values, p, n * sizeof(cl_object));
}
cl_object
ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size)
{
cl_object *base = env->stack_top;
if (size) {
if ((env->stack_limit - base) < size) {
base = ecl_stack_set_size(env, env->stack_size + size);
}
}
f->frame.t = t_frame;
f->frame.stack = env->stack;
f->frame.base = base;
f->frame.size = size;
f->frame.env = env;
env->stack_top = (base + size);
return f;
}
void
ecl_stack_frame_push(cl_object f, cl_object o)
{
cl_env_ptr env = f->frame.env;
cl_object *top = env->stack_top;
if (top >= env->stack_limit) {
top = ecl_stack_grow(env);
}
env->stack_top = ++top;
*(top-1) = o;
f->frame.base = top - (++(f->frame.size));
f->frame.stack = env->stack;
}
void
ecl_stack_frame_push_values(cl_object f)
{
cl_env_ptr env = f->frame.env;
ecl_stack_push_values(env);
f->frame.base = env->stack_top - (f->frame.size += env->nvalues);
f->frame.stack = env->stack;
}
cl_object
ecl_stack_frame_pop_values(cl_object f)
{
cl_env_ptr env = f->frame.env;
cl_index n = f->frame.size % ECL_MULTIPLE_VALUES_LIMIT;
cl_object o;
env->nvalues = n;
env->values[0] = o = ECL_NIL;
while (n--) {
env->values[n] = o = f->frame.base[n];
}
return o;
}
void
ecl_stack_frame_close(cl_object f)
{
if (f->frame.stack) {
ECL_STACK_SET_INDEX(f->frame.env, f->frame.base - f->frame.stack);
}
}
/* ------------------------- BINDING STACK ---------------------------- */
void
ecl_bds_unwind_n(cl_env_ptr env, int n)
@ -248,20 +391,22 @@ cl_object
si_bds_top()
{
cl_env_ptr env = ecl_process_env();
@(return ecl_make_fixnum(env->bds_top - env->bds_org));
ecl_return1(env, ecl_make_fixnum(env->bds_top - env->bds_org));
}
cl_object
si_bds_var(cl_object arg)
{
@(return get_bds_ptr(arg)->symbol);
cl_env_ptr env = ecl_process_env();
ecl_return1(env, get_bds_ptr(arg)->symbol);
}
cl_object
si_bds_val(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
cl_object v = get_bds_ptr(arg)->value;
@(return ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v));
ecl_return1(env, ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v));
}
#ifdef ecl_bds_bind
@ -289,7 +434,6 @@ ecl_new_binding_index(cl_env_ptr env, cl_object symbol)
new_index = ecl_atomic_index_incf(&cl_core.last_var_index);
}
symbol->symbol.binding = new_index;
symbol->symbol.dynamic |= 1;
}
ecl_set_finalizer_unprotected(symbol, ECL_T);
return new_index;
@ -433,7 +577,7 @@ ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value)
}
#endif /* ECL_THREADS */
/******************** INVOCATION STACK **********************/
/* ------------------------- INVOCATION STACK ------------------------- */
static ecl_ihs_ptr
get_ihs_ptr(cl_index n)
@ -451,40 +595,45 @@ cl_object
si_ihs_top(void)
{
cl_env_ptr env = ecl_process_env();
@(return ecl_make_fixnum(env->ihs_top->index));
ecl_return1(env, ecl_make_fixnum(env->ihs_top->index));
}
cl_object
si_ihs_prev(cl_object x)
{
@(return cl_1M(x));
cl_env_ptr env = ecl_process_env();
ecl_return1(env, cl_1M(x));
}
cl_object
si_ihs_next(cl_object x)
{
@(return cl_1P(x));
cl_env_ptr env = ecl_process_env();
ecl_return1(env, cl_1P(x));
}
cl_object
si_ihs_bds(cl_object arg)
{
@(return ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds));
cl_env_ptr env = ecl_process_env();
ecl_return1(env, ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds));
}
cl_object
si_ihs_fun(cl_object arg)
{
@(return get_ihs_ptr(ecl_to_size(arg))->function);
cl_env_ptr env = ecl_process_env();
ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->function);
}
cl_object
si_ihs_env(cl_object arg)
{
@(return get_ihs_ptr(ecl_to_size(arg))->lex_env);
cl_env_ptr env = ecl_process_env();
ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_env);
}
/********************** FRAME STACK *************************/
/* ------------------------- FRAME STACK ------------------------------ */
static void
frs_set_size(cl_env_ptr env, cl_index new_size)
@ -600,25 +749,28 @@ cl_object
si_frs_top()
{
cl_env_ptr env = ecl_process_env();
@(return ecl_make_fixnum(env->frs_top - env->frs_org));
ecl_return1(env, ecl_make_fixnum(env->frs_top - env->frs_org));
}
cl_object
si_frs_bds(cl_object arg)
{
@(return ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_top_index));
cl_env_ptr env = ecl_process_env();
ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_top_index));
}
cl_object
si_frs_tag(cl_object arg)
{
@(return get_frame_ptr(arg)->frs_val);
cl_env_ptr env = ecl_process_env();
ecl_return1(env, get_frame_ptr(arg)->frs_val);
}
cl_object
si_frs_ihs(cl_object arg)
{
@(return ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index));
cl_env_ptr env = ecl_process_env();
ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index));
}
cl_object
@ -630,10 +782,10 @@ si_sch_frs_base(cl_object fr, cl_object ihs)
for (x = get_frame_ptr(fr);
x <= env->frs_top && x->frs_ihs->index < y;
x++);
@(return ((x > env->frs_top) ? ECL_NIL : ecl_make_fixnum(x - env->frs_org)));
ecl_return1(env, ((x > env->frs_top) ? ECL_NIL : ecl_make_fixnum(x - env->frs_org)));
}
/********************* INITIALIZATION ***********************/
/* ------------------------- INITIALIZATION --------------------------- */
cl_object
si_set_limit(cl_object type, cl_object limit)
@ -664,7 +816,7 @@ si_set_limit(cl_object type, cl_object limit)
_ecl_set_max_heap_size(the_size);
}
return si_get_limit(type);
ecl_return1(env, si_get_limit(type));
}
cl_object
@ -682,10 +834,10 @@ si_get_limit(cl_object type)
output = env->stack_limit_size;
else {
/* size_t can be larger than cl_index */
@(return ecl_make_unsigned_integer(cl_core.max_heap_size));
ecl_return1(env, ecl_make_unsigned_integer(cl_core.max_heap_size));
}
@(return ecl_make_unsigned_integer(output));
ecl_return1(env, ecl_make_unsigned_integer(output));
}
cl_object
@ -699,9 +851,9 @@ si_reset_margin(cl_object type)
else if (type == @'ext::c-stack')
cs_set_size(env, env->cs_size);
else
return ECL_NIL;
ecl_return1(env, ECL_NIL);
return ECL_T;
ecl_return1(env, ECL_T);
}
void
@ -709,23 +861,29 @@ init_stacks(cl_env_ptr env)
{
static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0};
cl_index size, margin;
/* frame stack */
margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin;
env->frs_size = size;
env->frs_org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_org));
env->frs_top = env->frs_org-1;
env->frs_limit = &env->frs_org[size - 2*margin];
/* bind stack */
margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin;
env->bds_size = size;
env->bds_org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_org));
env->bds_top = env->bds_org-1;
env->bds_limit = &env->bds_org[size - 2*margin];
/* ihs stack */
env->ihs_top = &ihs_org;
ihs_org.function = ECL_NIL;
ihs_org.lex_env = ECL_NIL;
ihs_org.index = 0;
/* lisp stack */
env->stack = NULL;
env->stack_top = NULL;
env->stack_limit = NULL;
env->stack_size = 0;
ecl_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]);
}

2
src/c/symbol.d
View file

@ -102,7 +102,6 @@ cl_make_symbol(cl_object str)
}
x = ecl_alloc_object(t_symbol);
x->symbol.name = str;
x->symbol.dynamic = 0;
#ifdef ECL_THREADS
x->symbol.binding = ECL_MISSING_SPECIAL_BINDING;
#endif /* */
@ -323,7 +322,6 @@ cl_symbol_name(cl_object x)
sym = ECL_NIL_SYMBOL;
x = cl_make_symbol(ecl_symbol_name(sym));
if (!Null(cp)) {
x->symbol.dynamic = 0;
x->symbol.stype = sym->symbol.stype;
x->symbol.value = sym->symbol.value;
x->symbol.gfdef = sym->symbol.gfdef;

20
src/c/symbols_list.h Executable file → Normal file
View file

@ -106,8 +106,8 @@ cl_symbols[] = {
{SYS_ "UNBOUND" ECL_FUN("si_unbound", si_unbound, 0) ECL_VAR(SI_CONSTANT, ECL_UNBOUND)},
{SYS_ "PROTECT-TAG" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "DUMMY-TAG" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "*RESTART-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, Cnil)},
{SYS_ "*HANDLER-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, Cnil)},
{SYS_ "*RESTART-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)},
{SYS_ "*HANDLER-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)},
{EXT_ "*INTERRUPTS-ENABLED*" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_SPECIAL, ECL_T)},
/* LISP PACKAGE */
@ -1569,21 +1569,7 @@ cl_symbols[] = {
{EXT_ "GC" ECL_FUN("si_gc", si_gc, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)},
{SYS_ "GC-DUMP" ECL_FUN("si_gc_dump", si_gc_dump, 0) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "GC-STATS" ECL_FUN("si_gc_stats", si_gc_stats, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
#else
{EXT_ "GC" ECL_FUN("si_gc", si_gc, -2) ECL_VAR(EXT_ORDINARY, OBJNULL)},
{SYS_ "ALLOCATE" ECL_FUN("si_allocate", si_allocate, -3) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "ALLOCATED-PAGES" ECL_FUN("si_allocated_pages", si_allocated_pages, -2) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "MAXIMUM-ALLOCATABLE-PAGES" ECL_FUN("si_maximum_allocatable_pages", si_maximum_allocatable_pages, -2) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "ALLOCATE-CONTIGUOUS-PAGES" ECL_FUN("si_allocate_contiguous_pages", si_allocate_contiguous_pages, -2) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "ALLOCATED-CONTIGUOUS-PAGES" ECL_FUN("si_allocated_contiguous_pages", si_allocated_contiguous_pages, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "MAXIMUM-CONTIGUOUS-PAGES" ECL_FUN("si_maximum_contiguous_pages", si_maximum_contiguous_pages, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "GC-TIME" ECL_FUN("si_gc_time", si_gc_time, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "GET-HOLE-SIZE" ECL_FUN("si_get_hole_size", si_get_hole_size, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "SET-HOLE-SIZE" ECL_FUN("si_set_hole_size", si_set_hole_size, -2) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "IGNORE-MAXIMUM-PAGES" ECL_FUN("si_ignore_maximum_pages", si_ignore_maximum_pages, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "ROOM-REPORT" ECL_FUN("si_room_report", si_room_report, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "RESET-GC-COUNT" ECL_FUN("si_reset_gc_count", si_reset_gc_count, -1) ECL_VAR(SI_ORDINARY, OBJNULL)},
#endif /* !GBC_BOEHM */
#endif
{EXT_ "TIMEOUT" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)},
/* #ifdef ECL_THREADS */
{MP_ "PROCESS" ECL_FUN(NULL, NULL, -1) ECL_VAR(MP_ORDINARY, OBJNULL)},

181
src/c/threads/process.d
View file

@ -10,6 +10,11 @@
*
*/
#define ECL_INCLUDE_MATH_H
#include <ecl/ecl.h> /* includes ECL_WINDOWS_THREADS */
#include <ecl/internal.h>
#include <ecl/ecl-inl.h>
#ifndef __sun__ /* See unixinit.d for this */
#define _XOPEN_SOURCE 600 /* For pthread mutex attributes */
#endif
@ -17,8 +22,6 @@
#include <time.h>
#include <signal.h>
#include <string.h>
#define ECL_INCLUDE_MATH_H
#include <ecl/ecl.h>
#ifdef ECL_WINDOWS_THREADS
# include <windows.h>
#else
@ -30,62 +33,66 @@
#ifdef HAVE_SCHED_H
# include <sched.h>
#endif
#include <ecl/internal.h>
#include <ecl/ecl-inl.h>
/* -- Macros -------------------------------------------------------- */
#ifdef ECL_WINDOWS_THREADS
DWORD cl_env_key;
# define ecl_process_key_t DWORD
# define ecl_process_key_create(key) key = TlsAlloc()
# define ecl_process_get_tls(key) TlsGetValue(key)
# define ecl_process_set_tls(key,val) (TlsSetValue(key,val)!=0)
# define ecl_process_eq(t1, t2) (GetThreadId(t1) == GetThreadId(t2))
# define ecl_set_process_self(var) \
{ \
HANDLE aux = GetCurrentThread(); \
DuplicateHandle(GetCurrentProcess(), \
aux, \
GetCurrentProcess(), \
&var, \
0, \
FALSE, \
DUPLICATE_SAME_ACCESS); \
}
#else
static pthread_key_t cl_env_key;
#endif /* ECL_WINDOWS_THREADS */
# define ecl_process_key_t static pthread_key_t
# define ecl_process_key_create(key) pthread_key_create(&key, NULL)
# define ecl_process_get_tls(key) pthread_getspecific(key)
# define ecl_process_set_tls(key,val) (pthread_setspecific(key,val)==0)
# define ecl_process_eq(t1, t2) (t1 == t2)
# define ecl_set_process_self(var) (var = pthread_self())
#endif /* ECL_WINDOWS_THREADS */
extern void ecl_init_env(struct cl_env_struct *env);
/* -- Core ---------------------------------------------------------- */
/* Accessing a thread-local variable representing the environment. */
ecl_process_key_t cl_env_key;
cl_env_ptr
ecl_process_env_unsafe(void)
{
#ifdef ECL_WINDOWS_THREADS
return TlsGetValue(cl_env_key);
#else
return pthread_getspecific(cl_env_key);
#endif
return ecl_process_get_tls(cl_env_key);
}
cl_env_ptr
ecl_process_env(void)
{
#ifdef ECL_WINDOWS_THREADS
return TlsGetValue(cl_env_key);
#else
struct cl_env_struct *rv = pthread_getspecific(cl_env_key);
if (rv)
return rv;
ecl_thread_internal_error("pthread_getspecific() failed.");
return NULL;
#endif
cl_env_ptr rv = ecl_process_get_tls(cl_env_key);
if(!rv) {
ecl_thread_internal_error("pthread_getspecific() failed.");
}
return rv;
}
static void
ecl_set_process_env(cl_env_ptr env)
{
#ifdef ECL_WINDOWS_THREADS
TlsSetValue(cl_env_key, env);
#else
if (pthread_setspecific(cl_env_key, env)) {
if(!ecl_process_set_tls(cl_env_key, env)) {
ecl_thread_internal_error("pthread_setspecific() failed.");
}
#endif
}
cl_object
mp_current_process(void)
{
return ecl_process_env()->own_process;
}
/*----------------------------------------------------------------------
* PROCESS LIST
*/
/* Managing the collection of processes. */
static void
extend_process_vector()
@ -166,9 +173,29 @@ ecl_process_list()
return output;
}
/*----------------------------------------------------------------------
* THREAD OBJECT
*/
/* Initialiation */
static void
init_process(void)
{
ecl_process_key_create(cl_env_key);
ecl_mutex_init(&cl_core.processes_lock, 1);
ecl_mutex_init(&cl_core.global_lock, 1);
ecl_mutex_init(&cl_core.error_lock, 1);
ecl_rwlock_init(&cl_core.global_env_lock);
}
/* -- Environment --------------------------------------------------- */
extern void ecl_init_env(struct cl_env_struct *env);
cl_object
mp_current_process(void)
{
return ecl_process_env()->own_process;
}
/* -- Thread object ------------------------------------------------- */
static void
assert_type_process(cl_object o)
@ -223,11 +250,11 @@ thread_cleanup(void *aux)
}
#ifdef ECL_WINDOWS_THREADS
static DWORD WINAPI thread_entry_point(void *arg)
static DWORD WINAPI
#else
static void *
thread_entry_point(void *arg)
static void *
#endif
thread_entry_point(void *arg)
{
cl_object process = (cl_object)arg;
cl_env_ptr env = process->process.env;
@ -320,7 +347,6 @@ alloc_process(cl_object name, cl_object initial_bindings)
}
process->process.initial_bindings = array;
process->process.woken_up = ECL_NIL;
process->process.queue_record = ecl_list1(process);
ecl_disable_interrupts_env(env);
ecl_mutex_init(&process->process.start_stop_lock, TRUE);
ecl_cond_var_init(&process->process.exit_barrier);
@ -334,27 +360,11 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
{
struct cl_env_struct env_aux[1];
cl_object process;
pthread_t current;
ecl_thread_t current;
cl_env_ptr env;
int registered;
struct GC_stack_base stack;
#ifdef ECL_WINDOWS_THREADS
{
HANDLE aux = GetCurrentThread();
if ( !DuplicateHandle(GetCurrentProcess(),
aux,
GetCurrentProcess(),
&current,
0,
FALSE,
DUPLICATE_SAME_ACCESS) )
{
return 0;
}
}
#else
current = pthread_self();
#endif
ecl_set_process_self(current);
#ifdef GBC_BOEHM
GC_get_stack_base(&stack);
switch (GC_register_my_thread(&stack)) {
@ -375,15 +385,9 @@ ecl_import_current_thread(cl_object name, cl_object bindings)
cl_index i, size;
for (i = 0, size = processes->vector.fillp; i < size; i++) {
cl_object p = processes->vector.self.t[i];
if (!Null(p)
&&
#ifdef ECL_WINDOWS_THREADS
GetThreadId(p->process.thread) == GetThreadId(current)
#else
p->process.thread == current
#endif
)
return 0;
if (!Null(p) && ecl_process_eq(p->process.thread, current)) {
return 0;
}
}
}
/* We need a fake env to allow for interrupts blocking and to set up
@ -791,41 +795,18 @@ mp_restore_signals(cl_object sigmask)
#endif
}
/*----------------------------------------------------------------------
* INITIALIZATION
*/
/* -- Initialization ------------------------------------------------ */
void
init_threads(cl_env_ptr env)
{
cl_object process;
pthread_t main_thread;
cl_core.processes = OBJNULL;
ecl_thread_t main_thread;
init_process();
/* We have to set the environment before any allocation takes place,
* so that the interrupt handling code works. */
#if defined(ECL_WINDOWS_THREADS)
cl_env_key = TlsAlloc();
#else
pthread_key_create(&cl_env_key, NULL);
#endif
ecl_set_process_env(env);
#ifdef ECL_WINDOWS_THREADS
{
HANDLE aux = GetCurrentThread();
DuplicateHandle(GetCurrentProcess(),
aux,
GetCurrentProcess(),
&main_thread,
0,
FALSE,
DUPLICATE_SAME_ACCESS);
}
#else
main_thread = pthread_self();
#endif
ecl_set_process_self(main_thread);
process = ecl_alloc_object(t_process);
process->process.phase = ECL_PROCESS_ACTIVE;
process->process.name = @'si::top-level';
@ -834,12 +815,10 @@ init_threads(cl_env_ptr env)
process->process.thread = main_thread;
process->process.env = env;
process->process.woken_up = ECL_NIL;
process->process.queue_record = ecl_list1(process);
ecl_mutex_init(&process->process.start_stop_lock, TRUE);
ecl_cond_var_init(&process->process.exit_barrier);
env->own_process = process;
{
cl_object v = si_make_vector(ECL_T, /* Element type */
ecl_make_fixnum(256), /* Size */
@ -848,9 +827,5 @@ init_threads(cl_env_ptr env)
v->vector.self.t[0] = process;
v->vector.fillp = 1;
cl_core.processes = v;
ecl_mutex_init(&cl_core.processes_lock, 1);
ecl_mutex_init(&cl_core.global_lock, 1);
ecl_mutex_init(&cl_core.error_lock, 1);
ecl_rwlock_init(&cl_core.global_env_lock);
}
}

18
src/clos/conditions.lsp
View file

@ -401,9 +401,8 @@
(let* ((condition
(coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL))
(*handler-clusters* *handler-clusters*))
(if (typep condition *break-on-signals*)
(break "~A~%Break entered because of *BREAK-ON-SIGNALS*."
condition))
(when (typep condition *break-on-signals*)
(break "~A~%Break entered because of *BREAK-ON-SIGNALS*." condition))
(loop (unless *handler-clusters* (return))
(let ((cluster (pop *handler-clusters*)))
(dolist (handler cluster)
@ -872,13 +871,12 @@ strings."
; from CEerror
(with-simple-restart (accept "Accept the error, returning NIL")
(multiple-value-bind (rv used-restart)
(with-simple-restart (ignore "Ignore the error, and try the operation again")
(multiple-value-bind (rv used-restart)
(with-simple-restart (continue "Continue, using ~S" continue-string)
(signal condition)
(invoke-debugger condition))
(if used-restart continue-string rv)))
(with-simple-restart (ignore "Ignore the error, and try the operation again")
(multiple-value-bind (rv used-restart)
(with-simple-restart (continue "Continue, using ~S" continue-string)
(signal condition)
(invoke-debugger condition))
(if used-restart continue-string rv)))
(if used-restart t rv))))
(t
(progn

46
src/doc/help.lsp
View file

@ -397,20 +397,6 @@ Otherwise, returns LIST.")
(docfun adjustable-array-p function (array) "
Returns T if ARRAY is adjustable; NIL otherwise.")
#-boehm-gc
(docfun allocate function (type number &optional (really-allocate nil)) "
ECL specific.
Sets the maximum number of pages for the type class of the ECL implementation
type TYPE to NUMBER. If REALLY-ALLOCATE is non-NIL, then the specified number
of pages will be allocated immediately.")
#-boehm-gc
(docfun si::allocate-contiguous-pages function (number &optional (really-allocate nil)) "
ECL specific.
Sets the maximum number of pages for contiguous blocks to NUMBER. If REALLY-
ALLOCATE is non-NIL, then the specified number of pages will be allocated
immediately.")
#+clos
(docfun si::allocate-gfun function (name arity hash-table) "
ECL/CLOS specific.
@ -423,17 +409,6 @@ methods.")
ECL/CLOS specific.
Allocates an istance of CLASS with LENGTH slots.")
#-boehm-gc
(docfun si::allocated-contiguous-pages function () "
ECL specific.
Returns the number of pages currently allocated for contiguous blocks.")
#-boehm-gc
(docfun si::allocated-pages function (type) "
ECL specific.
Returns the number of pages currently allocated for the type class of the ECL
implementation type TYPE.")
(docfun alpha-char-p function (char) "
Returns T if CHAR is alphabetic; NIL otherwise.")
@ -1495,11 +1470,6 @@ ECL specific.
Starts garbage collection with the specified collection level. If X is NIL,
collects only cells. If X is T, collects everything.")
#-boehm-gc
(docfun si::gc-time function () "
ECL specific.
Returns the amount of time (in 1/100 seconds) spent during garbage collection.")
(docfun gcd function (&rest integers) "
Returns the greatest common divisor of the args.")
@ -1523,11 +1493,6 @@ If found, returns the value of the property. Otherwise, returns DEFAULT.")
Returns the read macro for SUBCHAR associated with the dispatch macro
character CHAR in READTABLE.")
#-boehm-gc
(docfun si::get-hole-size function () "
ECL specific.
Returns as a fixnum the size of the memory hole (in pages).")
(docfun get-internal-real-time function () "
Returns the time (in 1/100 seconds) since the invocation of ECL.")
@ -2111,11 +2076,6 @@ ECL specific.
Returns the current maximum number of pages for the type class of the ECL
implementation type TYPE.")
#-boehm-gc
(docfun si::maximum-contiguous-pages function () "
ECL specific.
Returns the current maximum number of pages for contiguous blocks.")
(docfun member function (item list &key (key '#'identity) (test '#'eql) test-not) "
Searches LIST for an element that is equal to ITEM in the sense of the TEST.
If found, returns the sublist of LIST that begins with the element.
@ -2662,12 +2622,6 @@ See MAKE-PACKAGE.")
Replaces elements of SEQUENCE1 with the corresponding elements of SEQUENCE2.
SEQUENCE1 may be destroyed and is returned.")
#-boehm-gc
(docfun si::reset-gc-count function () "
ECL specific.
Resets the counter of the garbage collector that records how many times the
garbage collector has been called for each implementation type.")
(docfun rest function (x) "
Equivalent to CDR.")

61
src/h/external.h
View file

@ -150,7 +150,9 @@ struct cl_env_struct {
struct ecl_interrupt_struct {
cl_object pending_interrupt;
cl_object signal_queue;
#ifdef ECL_THREADS
ecl_mutex_t signal_queue_lock;
#endif
};
#ifndef __GNUC__
@ -196,7 +198,6 @@ struct cl_core_struct {
cl_object error_output;
cl_object standard_readtable;
cl_object dispatch_reader;
cl_object default_dispatch_macro;
cl_object char_names;
cl_object null_string;
@ -262,12 +263,15 @@ extern ECL_API struct cl_core_struct cl_core;
extern ECL_API cl_object ecl_alloc_object(cl_type t);
extern ECL_API cl_object ecl_alloc_instance(cl_index slots);
extern ECL_API cl_object ecl_alloc_weak_pointer(cl_object o);
extern ECL_API cl_object ecl_alloc_compact_object(cl_type t, cl_index extra_space);
extern ECL_API cl_object ecl_cons(cl_object a, cl_object d);
extern ECL_API cl_object ecl_list1(cl_object a);
#define ecl_list1(x) ecl_cons(x, ECL_NIL)
extern ECL_API cl_object si_make_weak_pointer(cl_object o);
extern ECL_API cl_object si_weak_pointer_value(cl_object o);
#ifdef GBC_BOEHM
extern ECL_API cl_object si_gc(cl_narg narg, ...);
extern ECL_API cl_object si_gc_dump(void);
extern ECL_API cl_object si_gc_stats(cl_object enable);
extern ECL_API void *ecl_alloc_unprotected(cl_index n);
extern ECL_API void *ecl_alloc_atomic_unprotected(cl_index n);
extern ECL_API void *ecl_alloc(cl_index n);
@ -277,30 +281,8 @@ extern ECL_API void ecl_free_uncollectable(void *);
extern ECL_API void ecl_dealloc(void *);
#define ecl_alloc_align(s,d) ecl_alloc(s)
#define ecl_alloc_atomic_align(s,d) ecl_alloc_atomic(s)
#define ecl_register_static_root(x) ecl_register_root(x)
extern ECL_API cl_object ecl_alloc_compact_object(cl_type t, cl_index extra_space);
extern ECL_API cl_object si_make_weak_pointer(cl_object o);
extern ECL_API cl_object si_weak_pointer_value(cl_object o);
#else
extern ECL_API cl_object si_allocate _ECL_ARGS((cl_narg narg, cl_object type, cl_object qty, ...));
extern ECL_API cl_object si_maximum_allocatable_pages _ECL_ARGS((cl_narg narg, cl_object type, ...));
extern ECL_API cl_object si_allocated_pages _ECL_ARGS((cl_narg narg, cl_object type, ...));
extern ECL_API cl_object si_alloc_contpage _ECL_ARGS((cl_narg narg, cl_object qty, ...));
extern ECL_API cl_object si_allocated_contiguous_pages _ECL_ARGS((cl_narg narg, ...));
extern ECL_API cl_object si_maximum_contiguous_pages _ECL_ARGS((cl_narg narg, ...));
extern ECL_API cl_object si_allocate_contiguous_pages _ECL_ARGS((cl_narg narg, cl_object qty, ...));
extern ECL_API cl_object si_get_hole_size _ECL_ARGS((cl_narg narg, ...));
extern ECL_API cl_object si_set_hole_size _ECL_ARGS((cl_narg narg, cl_object size, ...));
extern ECL_API cl_object si_ignore_maximum_pages _ECL_ARGS((cl_narg narg, ...));
extern ECL_API void *ecl_alloc(cl_index n);
extern ECL_API void *ecl_alloc_align(cl_index size, cl_index align);
extern ECL_API void *ecl_alloc_uncollectable(size_t size);
extern ECL_API void ecl_free_uncollectable(void *);
extern ECL_API void ecl_dealloc(void *p);
#define ecl_alloc_atomic(x) ecl_alloc(x)
#define ecl_alloc_atomic_align(x,s) ecl_alloc_align(x,s)
#define ecl_register_static_root(x) ecl_register_root(x);
#else /* Ideally the core would not depend on these. */
# error "IMPLEMENT ME!"
#endif /* GBC_BOEHM */
/* all_symbols */
@ -689,6 +671,7 @@ extern ECL_API void ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag type, cl_
#define ECL_LISTEN_NO_CHAR 0
#define ECL_LISTEN_AVAILABLE 1
#define ECL_LISTEN_EOF -1
#define ECL_LISTEN_FALLBACK -3
extern ECL_API cl_object cl_make_synonym_stream(cl_object sym);
extern ECL_API cl_object cl_synonym_stream_symbol(cl_object strm);
@ -773,26 +756,16 @@ extern ECL_API cl_object cl_format _ECL_ARGS((cl_narg narg, cl_object stream, cl
/* gbc.c */
#if !defined(GBC_BOEHM)
extern ECL_API cl_object si_room_report _ECL_ARGS((cl_narg narg, ...));
extern ECL_API cl_object si_reset_gc_count _ECL_ARGS((cl_narg narg, ...));
extern ECL_API cl_object si_gc_time _ECL_ARGS((cl_narg narg, ...));
extern ECL_API cl_object si_gc(cl_object area, ...);
#define GC_enabled() GC_enable
#define GC_enable() GC_enable = TRUE;
#define GC_disable() GC_enable = FALSE;
extern ECL_API bool GC_enable;
extern ECL_API cl_object (*GC_enter_hook)(void);
extern ECL_API cl_object (*GC_exit_hook)(void);
extern ECL_API void ecl_register_root(cl_object *p);
extern ECL_API void ecl_gc(cl_type t);
#endif
#ifdef GBC_BOEHM
#define GC_enabled() !GC_is_disabled()
#define GC_enable() GC_enable()
#define GC_disable() GC_disable()
extern ECL_API void ecl_register_root(cl_object *p);
extern ECL_API cl_object si_gc(cl_narg narg, ...);
extern ECL_API cl_object si_gc_dump(void);
extern ECL_API cl_object si_gc_stats(cl_object enable);
#else
# error "IMPLEMENT ME!"
#endif /* GBC_BOEHM */

9
src/h/internal.h
View file

@ -48,6 +48,8 @@ extern void init_unixtime(void);
extern void init_compiler(void);
#ifdef ECL_THREADS
extern void init_threads(cl_env_ptr);
#else
#define init_threads(env) cl_env_p = env
#endif
extern void ecl_init_env(cl_env_ptr);
extern void init_lib_LSP(cl_object);
@ -398,6 +400,13 @@ extern void ecl_cs_set_org(cl_env_ptr env);
#ifdef ECL_THREADS
extern ECL_API cl_object mp_suspend_loop();
extern ECL_API cl_object mp_break_suspend_loop();
# ifdef ECL_WINDOWS_THREADS
# define ecl_thread_exit() ExitThread(0);
# else
# define ecl_thread_exit() pthread_exit(NULL);
# endif /* ECL_WINDOWS_THREADS */
#endif
/* time.d */

12
src/h/object.h
View file

@ -275,7 +275,7 @@ enum ecl_stype { /* symbol type */
#define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS))
struct ecl_symbol {
_ECL_HDR2(stype, dynamic);/* symbol type, special-variable-p */
_ECL_HDR1(stype); /* symbol type */
cl_object value; /* global value of the symbol */
/* Coincides with cons.car */
cl_object gfdef; /* global function definition */
@ -917,6 +917,7 @@ struct ecl_weak_pointer { /* weak pointer to value */
_ECL_HDR;
cl_object value;
};
#define ecl_weak_pointer(o) ((o)->weak.value)
/*
dummy type
@ -928,6 +929,7 @@ struct ecl_dummy {
#ifdef ECL_THREADS
#ifdef ECL_WINDOWS_THREADS
typedef HANDLE ecl_thread_t;
typedef HANDLE ecl_mutex_t;
typedef struct ecl_cond_var_t {
HANDLE broadcast_event;
@ -936,6 +938,7 @@ typedef struct ecl_cond_var_t {
} ecl_cond_var_t;
typedef SRWLOCK ecl_rwlock_t;
#else
typedef pthread_t ecl_thread_t;
typedef pthread_mutex_t ecl_mutex_t;
typedef pthread_cond_t ecl_cond_var_t;
# ifdef HAVE_POSIX_RWLOCK
@ -971,15 +974,10 @@ struct ecl_process {
cl_object parent;
cl_object exit_values;
cl_object woken_up;
cl_object queue_record;
ecl_mutex_t start_stop_lock; /* phase is updated only when we hold this lock */
ecl_cond_var_t exit_barrier; /* process-join waits on this barrier */
cl_index phase;
#ifdef ECL_WINDOWS_THREADS
HANDLE thread;
#else
pthread_t thread;
#endif
ecl_thread_t thread;
int trap_fpe_bits;
};

94
src/h/page.h
View file

@ -36,100 +36,6 @@ extern struct typemanager {
#define tm_of(t) (&tm_table[(int)(t)])
#endif
/****************************************
* ECOLISP's ORIGINAL GARBAGE COLLECTOR *
****************************************/
#if !defined(GBC_BOEHM)
/* THREADS: If you make it bigger, the bug is less frequent */
#ifdef SYSV
#define HOLEPAGE 32
#else
#define HOLEPAGE 128
#endif
#define INIT_HOLEPAGE 150
#define CBMINSIZE 64 /* contiguous block minimal size */
typedef char *cl_ptr;
#define ptr2int(p) ((cl_ptr)(p) - (cl_ptr)0)
#define int2ptr(n) ((cl_ptr)0 + (n))
#define page(p) (((cl_ptr)(p) - heap_start)/LISP_PAGESIZE)
#define pagetochar(x) (heap_start + (x) * LISP_PAGESIZE)
#define round_to_page(x) (((x) + LISP_PAGESIZE - 1) / LISP_PAGESIZE)
#define round_up(n) (((n) + 03) & ~03)
#define available_pages() ((cl_index)(real_maxpage-page(heap_end)-new_holepage-real_maxpage/32))
extern cl_index real_maxpage;
extern cl_index new_holepage;
/*
The struct of free lists.
*/
struct freelist {
HEADER;
cl_object f_link;
};
/*
Type map.
enum type type_map[MAXPAGE];
*/
extern char type_map[MAXPAGE];
/*
Storage manager for each type.
*/
struct typemanager {
cl_type tm_type; /* type */
cl_index tm_size; /* element size in bytes */
cl_index tm_nppage; /* number per page */
cl_object tm_free; /* free list */
/* Note that it is of type object. */
cl_index tm_nfree; /* number of free elements */
cl_index tm_nused; /* number of elements used */
cl_index tm_npage; /* number of pages */
cl_index tm_maxpage; /* maximum number of pages */
char *tm_name; /* type name */
cl_index tm_gccount; /* GC count */
};
/*
The table of type managers.
*/
extern struct typemanager tm_table[(int)t_end];
#define tm_of(t) (&(tm_table[(int)tm_table[(int)(t)].tm_type]))
/*
Contiguous block header.
*/
struct contblock { /* contiguous block header */
cl_index cb_size; /* size in bytes */
struct contblock *cb_link; /* contiguous block link */
};
/*
The pointer to the contiguous blocks.
*/
extern struct contblock *cb_pointer; /* contblock pointer */
/*
Variables for memory management.
*/
extern cl_index ncb; /* number of contblocks */
extern cl_index ncbpage; /* number of contblock pages */
extern cl_index maxcbpage; /* maximum number of contblock pages */
extern cl_index cbgccount; /* contblock gc count */
extern cl_index holepage; /* hole pages */
extern char *heap_start; /* heap start */
extern char *heap_end; /* heap end */
extern char *data_end; /* core end */
#endif /* !GBC_BOEHM */
/*******************************
* SYMBOLS & KEYWORDS DATABASE *
*******************************/

2
src/tests/normal-tests/embedding.lsp
View file

@ -72,7 +72,7 @@
int main (int argc, char **argv) {
cl_object x;
cl_boot(argc, argv);
si_safe_eval(3, x = c_string_to_object(~S), Cnil, Cnil);
si_safe_eval(3, x = c_string_to_object(~S), ECL_NIL, ECL_NIL);
cl_shutdown();
exit(0);
}")