From 4366fac6ada1be696defad51cacc15c1fc7ede75 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 1 Jun 2022 14:07:27 +0200 Subject: [PATCH 01/21] portability: repair builds for --enable-threads=no A few blocks were not guarded with #ifdef ECL_THREADS ... #endif --- src/c/main.d | 4 ++++ src/h/external.h | 2 ++ 2 files changed, 6 insertions(+) diff --git a/src/c/main.d b/src/c/main.d index 2d2f9837a..1bfb0414c 100755 --- a/src/c/main.d +++ b/src/c/main.d @@ -181,7 +181,9 @@ ecl_init_env(cl_env_ptr env) env->slot_cache = ecl_make_cache(3, 4096); 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)); @@ -208,7 +210,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."); diff --git a/src/h/external.h b/src/h/external.h index 5eda7034f..efabffd5d 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -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__ From f948001dee592363fa8a73b2b99719cf6955c03a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 3 Jun 2022 08:29:19 +0200 Subject: [PATCH 02/21] reader: ensure the correct function arity We've used void_reader as an implementation for sharp_{plus,minus}_reader - sharp readers accept three arguments while void_reader accepted two. - introduce void_reader3 - change sharp_{plus,minus}_reader to use void_reader3 - remove unused defines (leftovers from the past) - remove unused void_reader (with two arguments) --- src/c/read.d | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/src/c/read.d b/src/c/read.d index 0895ea3ff..efdbf7c2c 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -615,7 +615,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 +1101,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 +1278,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) From 2b52fe3ecb5cad7c923487f5dddf54003ba59d43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 14 Jun 2022 18:28:27 +0200 Subject: [PATCH 03/21] pathname_translations: use ecl_assqlp instead of @assoc ecl_assqlp is sufficient and does not require argument parsing at runtime. host is always checked to be a string, so the ecl_assoc test EQUAL will have the same effect as the previously checked STRING-EQUAL. --- src/c/pathname.d | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/c/pathname.d b/src/c/pathname.d index beaa7e641..d4567cb1c 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -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))); } From 67f9d6af271294c39855a2e49aff6d670b4102cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 11 Nov 2022 10:02:11 +0100 Subject: [PATCH 04/21] file.d: file_listen: refactor the function - instead of a magic number -3 define a constant ECL_LISTEN_FALLBACK - provide a separate definition for windows and not-windows --- src/c/file.d | 76 ++++++++++++++++++++++++++---------------------- src/h/external.h | 1 + 2 files changed, 43 insertions(+), 34 deletions(-) diff --git a/src/c/file.d b/src/c/file.d index eb9a05d2b..126135ef7 100755 --- a/src/c/file.d +++ b/src/c/file.d @@ -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. */ diff --git a/src/h/external.h b/src/h/external.h index efabffd5d..835001d64 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -691,6 +691,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); From 2bbf490071940a0a8c764b1ecbb3fdfd346ae42b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 17 Nov 2022 18:48:59 +0100 Subject: [PATCH 05/21] alloc_2.d: remove unused code paths - GBC_BOEHM_OWN_ALLOCATOR is dead for a long time - undef alloc_object was used the function rename to ecl_alloc_object - remove mark phase ignored by the preprocessor --- src/c/alloc_2.d | 243 +----------------------------------------------- 1 file changed, 1 insertion(+), 242 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 7d1c300af..7f72bf668 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -39,14 +39,9 @@ static void ecl_mark_env(struct cl_env_struct *env); # undef GBC_BOEHM_PRECISE # else # include -# ifdef GBC_BOEHM_OWN_ALLOCATOR -# include -# 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; } @@ -784,19 +550,12 @@ init_alloc(void) 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 +# 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 */ From c591cfdb4755ac8a44feff70db90a254a875c051 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 17 Nov 2022 18:36:46 +0100 Subject: [PATCH 06/21] stacks.d: always use explicit ecl_return1 --- src/c/stacks.d | 48 +++++++++++++++++++++++++++++------------------- 1 file changed, 29 insertions(+), 19 deletions(-) diff --git a/src/c/stacks.d b/src/c/stacks.d index d8567a7e4..ecc35328d 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -248,20 +248,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 @@ -451,37 +453,42 @@ 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 *************************/ @@ -600,25 +607,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,7 +640,7 @@ 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 ***********************/ @@ -664,7 +674,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 +692,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 +709,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 From 21005498603316049d626a31b7bac2a7560064ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 17 Nov 2022 19:23:16 +0100 Subject: [PATCH 07/21] stacks.d: move the lisp stack from interpreter.d --- src/c/interpreter.d | 144 ----------------------------------------- src/c/stacks.d | 153 ++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 148 insertions(+), 149 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 79238e3f4..06b17e301 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -19,150 +19,6 @@ #include #include -/* -------------------- 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 diff --git a/src/c/stacks.d b/src/c/stacks.d index ecc35328d..6fb88f078 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -22,7 +22,7 @@ #include #include -/************************ 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) @@ -435,7 +578,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) @@ -491,7 +634,7 @@ si_ihs_env(cl_object arg) 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) @@ -643,7 +786,7 @@ si_sch_frs_base(cl_object fr, cl_object ihs) 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) From 93fabac00a18be762bb5deddd7c4c11b7a79a717 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 17 Nov 2022 20:37:25 +0100 Subject: [PATCH 08/21] cosmetic: use ECL_NIL instead of a deprecated constant Cnil --- src/c/cinit.d | 4 ++-- src/c/symbols_list.h | 4 ++-- src/tests/normal-tests/embedding.lsp | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/c/cinit.d b/src/c/cinit.d index 290156796..dcf9e53d9 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -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*'); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 28c519dff..ed3337a86 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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 */ diff --git a/src/tests/normal-tests/embedding.lsp b/src/tests/normal-tests/embedding.lsp index f6ef30b7c..a2ef7acb5 100644 --- a/src/tests/normal-tests/embedding.lsp +++ b/src/tests/normal-tests/embedding.lsp @@ -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); }") From e53b3d14bd50e17084b67ea98403eda8d3528fae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 19 Nov 2022 12:40:18 +0100 Subject: [PATCH 09/21] ecl_list1: redefine as a preprocessor macro This is the same as ecl_cons for all practical purposes so we simply put a define `#define ecl_list1(x) ecl_cons(x, ECL_NIL)`. --- src/c/alloc_2.d | 20 -------------------- src/h/external.h | 2 +- 2 files changed, 1 insertion(+), 21 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 7f72bf668..2c1964b75 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -387,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) { diff --git a/src/h/external.h b/src/h/external.h index 835001d64..6e481d627 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -265,7 +265,7 @@ 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_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) #ifdef GBC_BOEHM extern ECL_API cl_object si_gc(cl_narg narg, ...); extern ECL_API cl_object si_gc_dump(void); From 6c2cca684a723c465042a9d5f3b68e0ca580a63f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 19 Nov 2022 13:42:24 +0100 Subject: [PATCH 10/21] cleanup: remove lingering references to the old garbage collector --- src/c/alloc_2.d | 19 ++++----- src/c/main.d | 3 -- src/c/symbols_list.h | 16 +------- src/doc/help.lsp | 46 ---------------------- src/h/external.h | 55 ++++++-------------------- src/h/object.h | 1 + src/h/page.h | 94 -------------------------------------------- 7 files changed, 25 insertions(+), 209 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 2c1964b75..d104fb51b 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -1243,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(); @@ -1260,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) { @@ -1267,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); } } diff --git a/src/c/main.d b/src/c/main.d index 1bfb0414c..2d14faa82 100755 --- a/src/c/main.d +++ b/src/c/main.d @@ -630,10 +630,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(); /* diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index ed3337a86..e6334e529 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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)}, diff --git a/src/doc/help.lsp b/src/doc/help.lsp index f2bf7b2fa..6ff8608ed 100644 --- a/src/doc/help.lsp +++ b/src/doc/help.lsp @@ -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.") diff --git a/src/h/external.h b/src/h/external.h index 6e481d627..ef6e10564 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -264,12 +264,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); #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); @@ -279,30 +282,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 */ @@ -776,26 +757,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 */ diff --git a/src/h/object.h b/src/h/object.h index 578c61e9b..6df7e4606 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -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 diff --git a/src/h/page.h b/src/h/page.h index 6f8e131ae..1760a0ee1 100644 --- a/src/h/page.h +++ b/src/h/page.h @@ -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 * *******************************/ From a886b04a9adb5e24019502a06e8be0e9fc5047ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 20 Nov 2022 15:44:39 +0100 Subject: [PATCH 11/21] cosmetic: remove +x flag from source files --- src/c/dpp.c | 0 src/c/file.d | 0 src/c/main.d | 0 src/c/symbols_list.h | 0 4 files changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 src/c/dpp.c mode change 100755 => 100644 src/c/file.d mode change 100755 => 100644 src/c/main.d mode change 100755 => 100644 src/c/symbols_list.h diff --git a/src/c/dpp.c b/src/c/dpp.c old mode 100755 new mode 100644 diff --git a/src/c/file.d b/src/c/file.d old mode 100755 new mode 100644 diff --git a/src/c/main.d b/src/c/main.d old mode 100755 new mode 100644 diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h old mode 100755 new mode 100644 From 6ad85b259fdaa734a1dd58570e7c7670f73fa9e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 21 Nov 2022 10:15:28 +0100 Subject: [PATCH 12/21] ecl_symbol: remove unused field symbol.dynamic was only assigned, because we already encode this information in a bitfield using the enum ecl_stype. --- src/c/all_symbols.d | 1 - src/c/main.d | 2 -- src/c/stacks.d | 1 - src/c/symbol.d | 2 -- src/h/object.h | 2 +- 5 files changed, 1 insertion(+), 7 deletions(-) diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index f4b312bcc..59027bc11 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -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 diff --git a/src/c/main.d b/src/c/main.d index 2d14faa82..e6a9c0d8f 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -514,7 +514,6 @@ cl_boot(int argc, char **argv) */ 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; @@ -527,7 +526,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; diff --git a/src/c/stacks.d b/src/c/stacks.d index 6fb88f078..a39c6688a 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -434,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; diff --git a/src/c/symbol.d b/src/c/symbol.d index 300ef357d..a1000709a 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -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; diff --git a/src/h/object.h b/src/h/object.h index 6df7e4606..99f449470 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -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 */ From 9e10e9115eb2b5fb5cae0f98426f6192775d41fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 25 Nov 2022 10:13:49 +0100 Subject: [PATCH 13/21] cosmetic: introduce define ecl_thread_exit() --- src/c/error.d | 12 +++--------- src/h/internal.h | 7 +++++++ 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/c/error.d b/src/c/error.d index 6ae680e22..486960612 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -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 diff --git a/src/h/internal.h b/src/h/internal.h index f3f095d92..1f8efb0d3 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -398,6 +398,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 */ From 3ada3e96f7609ab3d9fdab5b610ee03b350a4123 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 24 Nov 2022 22:25:57 +0100 Subject: [PATCH 14/21] stacks: initialize the lisp stack in init_stacks --- src/c/main.d | 7 ------- src/c/stacks.d | 12 +++++++++--- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index e6a9c0d8f..4c6dc3d49 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -160,13 +160,6 @@ ecl_init_env(cl_env_ptr env) 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); #endif diff --git a/src/c/stacks.d b/src/c/stacks.d index a39c6688a..7cefe8cf3 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -861,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]); } From f9ad8de5310be5cb29420a24b49d3657b14eba3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 25 Nov 2022 10:47:10 +0100 Subject: [PATCH 15/21] cl_core: remove unused slot .default_dispatch_macro --- src/c/main.d | 1 - src/c/read.d | 33 ++++++++------------------------- src/h/external.h | 1 - 3 files changed, 8 insertions(+), 27 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index 4c6dc3d49..1d35509f1 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -382,7 +382,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, diff --git a/src/c/read.d b/src/c/read.d index efdbf7c2c..6af306d83 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -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); } @@ -1311,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 ... . */ @@ -1417,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; } @@ -1784,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 @@ -2071,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); @@ -2369,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)); } @@ -2405,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 diff --git a/src/h/external.h b/src/h/external.h index ef6e10564..f59a55a4e 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -198,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; From 1d5b8fd52599bfbf674a1fdb25d37cefc1766dbe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 21 Nov 2022 17:51:34 +0100 Subject: [PATCH 16/21] bignum: move ecl_init_bignum_registers to bignum.d --- src/c/big.d | 20 ++++++++++++++++++++ src/c/main.d | 22 ---------------------- 2 files changed, 20 insertions(+), 22 deletions(-) diff --git a/src/c/big.d b/src/c/big.d index ebb71c937..bb86dfcf9 100644 --- a/src/c/big.d +++ b/src/c/big.d @@ -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() { diff --git a/src/c/main.d b/src/c/main.d index 1d35509f1..c63520dcf 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -130,26 +130,6 @@ ecl_set_option(int option, cl_fixnum value) } } -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 ecl_init_env(cl_env_ptr env) { @@ -535,8 +515,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); From 285c12a2c6378f98d5159962f030682f770947f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 22 Nov 2022 14:12:22 +0100 Subject: [PATCH 17/21] cosmetic: indentation, s/if/when/ --- src/clos/conditions.lsp | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index dd63f1aa4..4aeb57428 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -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 From 95d7f4691c9a1a3b2003b39624f8d09974278d23 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 25 Nov 2022 16:55:26 +0100 Subject: [PATCH 18/21] cleanup: refactor ecl_init_env into smaller functions --- src/c/main.d | 66 +++++++++++++++++++++++++++++++++++----------------- 1 file changed, 45 insertions(+), 21 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index c63520dcf..bed342e06 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -130,28 +130,19 @@ ecl_set_option(int option, cl_fixnum value) } } -void -ecl_init_env(cl_env_ptr env) +static void +init_env_mp(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; -#if !defined(ECL_CMU_FORMAT) - env->fmt_aux_stream = ecl_make_string_output_stream(64, 1); -#endif -#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); +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 @@ -161,16 +152,49 @@ ecl_init_env(cl_env_ptr env) 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->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 +} + +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 From bd723748d7632cbae5a6edc784e5a3f48b0f4b7c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 25 Nov 2022 17:00:38 +0100 Subject: [PATCH 19/21] alloc_2: initialize the type info in a separate function The initialization is a lengthy function with clear responsibilities separate from the gc initialization. --- src/c/alloc_2.d | 143 ++++++++++++++++++++++++------------------------ 1 file changed, 72 insertions(+), 71 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index d104fb51b..595b28f1b 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -471,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) @@ -489,73 +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_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; - } - -#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; @@ -797,6 +735,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(); From 90483505bd0e9c4d7a22c261194dce43856c5b96 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 25 Nov 2022 20:43:31 +0100 Subject: [PATCH 20/21] cleanup: remove unused slot ecl_process.queue_record --- src/c/alloc_2.d | 3 +-- src/c/threads/process.d | 2 -- src/h/object.h | 1 - 3 files changed, 1 insertion(+), 5 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 595b28f1b..274dbaf96 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -675,8 +675,7 @@ void init_type_info (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)); diff --git a/src/c/threads/process.d b/src/c/threads/process.d index d93dc5fbf..c1b906c07 100755 --- a/src/c/threads/process.d +++ b/src/c/threads/process.d @@ -320,7 +320,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); @@ -834,7 +833,6 @@ 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); diff --git a/src/h/object.h b/src/h/object.h index 99f449470..d9b264e64 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -972,7 +972,6 @@ 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; From 80b74c890d88c29bbdd6c5fc416fc56d86042203 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 5 Dec 2022 00:18:21 +0100 Subject: [PATCH 21/21] cleanup: separate process managament from threads Additionally: - abstract platform specific functions with file-local macros --- src/c/main.d | 4 - src/c/threads/process.d | 179 +++++++++++++++++----------------------- src/h/internal.h | 2 + src/h/object.h | 8 +- 4 files changed, 83 insertions(+), 110 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index bed342e06..2774d4485 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -499,11 +499,7 @@ 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 diff --git a/src/c/threads/process.d b/src/c/threads/process.d index c1b906c07..097307c87 100755 --- a/src/c/threads/process.d +++ b/src/c/threads/process.d @@ -10,6 +10,11 @@ * */ +#define ECL_INCLUDE_MATH_H +#include /* includes ECL_WINDOWS_THREADS */ +#include +#include + #ifndef __sun__ /* See unixinit.d for this */ #define _XOPEN_SOURCE 600 /* For pthread mutex attributes */ #endif @@ -17,8 +22,6 @@ #include #include #include -#define ECL_INCLUDE_MATH_H -#include #ifdef ECL_WINDOWS_THREADS # include #else @@ -30,62 +33,66 @@ #ifdef HAVE_SCHED_H # include #endif -#include -#include + +/* -- 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; @@ -333,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(), - ¤t, - 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)) { @@ -374,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 @@ -790,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'; @@ -837,7 +819,6 @@ init_threads(cl_env_ptr env) 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 */ @@ -846,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); } } diff --git a/src/h/internal.h b/src/h/internal.h index 1f8efb0d3..466e0c8b7 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -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); diff --git a/src/h/object.h b/src/h/object.h index d9b264e64..915cd2604 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -929,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; @@ -937,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 @@ -975,11 +977,7 @@ struct ecl_process { 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; };