From cdff225681aff3a0097c4048c65e2666cc7a1655 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 24 Nov 2003 11:27:28 +0000 Subject: [PATCH] Implemented locking on hash tables and packages. Fixed several floating point contagion bugs in +, -, /, *, and ROUND. --- src/CHANGELOG | 3 + src/aclocal.m4 | 16 +- src/c/all_symbols.d | 49 +++--- src/c/alloc.d | 23 --- src/c/alloc_2.d | 3 +- src/c/error.d | 6 - src/c/file.d | 25 +-- src/c/gbc.d | 8 +- src/c/gfun.d | 2 +- src/c/hash.d | 102 +++++++----- src/c/list.d | 18 +++ src/c/load.d | 27 +++- src/c/main.d | 18 ++- src/c/num_arith.d | 30 +++- src/c/num_co.d | 33 +--- src/c/num_comp.d | 2 +- src/c/package.d | 362 ++++++++++++++++++++++++++++--------------- src/c/print.d | 45 ++---- src/c/read.d | 29 ++-- src/c/symbol.d | 2 +- src/c/symbols_list.h | 17 +- src/c/threads.d | 117 +++++++------- src/c/unixint.d | 166 +++++++------------- src/cmp/cmpdefs.lsp | 2 + src/cmp/cmpmain.lsp | 128 +++++++-------- src/h/ecl-cmp.h | 6 +- src/h/ecl.h | 6 +- src/h/external.h | 18 +-- src/h/internal.h | 44 +++++- src/h/object.h | 14 +- src/lsp/load.lsp.in | 6 +- 31 files changed, 751 insertions(+), 576 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 0a51c46de..a61f2e0ca 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1708,6 +1708,9 @@ ECL 0.9d permits combining (and repeating) the options -load, -eval, -shell in a number of ways. + - SI:FILE-COLUMN now always returns a number, which may be 0 for + streams that do not have that information. + TODO: ===== diff --git a/src/aclocal.m4 b/src/aclocal.m4 index 42614bfeb..8b8cd2bde 100644 --- a/src/aclocal.m4 +++ b/src/aclocal.m4 @@ -302,16 +302,28 @@ int main() { int_type="int"; for (bits=1; ((t << 1) >> 1) == t; bits++, t <<= 1); l = (~l) << (bits - 3); +#if 1 fprintf(f,"CL_FIXNUM_MIN='%d';",l); fprintf(f,"CL_FIXNUM_MAX='%d';",-(l+1)); +#else + l++; + fprintf(f,"CL_FIXNUM_MIN='%d';",l); + fprintf(f,"CL_FIXNUM_MAX='%d';",-l); +#endif } else if (sizeof(long) >= sizeof(void*)) { unsigned long int t = 1; signed long int l = 0; int_type="long int"; for (bits=1; ((t << 1) >> 1) == t; bits++, t <<= 1); l = (~l) << (bits - 3); - fprintf(f,"CL_FIXNUM_MIN='%ld';",l); - fprintf(f,"CL_FIXNUM_MAX='%ld';",-(l+1)); +#if 1 + fprintf(f,"CL_FIXNUM_MIN='%d';",l); + fprintf(f,"CL_FIXNUM_MAX='%d';",-(l+1)); +#else + l++; + fprintf(f,"CL_FIXNUM_MIN='%d';",l); + fprintf(f,"CL_FIXNUM_MAX='%d';",-l); +#endif } else exit(1); fprintf(f,"CL_FIXNUM_TYPE='%s';",int_type); diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 01859ff34..8ff5259f4 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -2,15 +2,26 @@ #include "ecl.h" #include "internal.h" -#define CL_ORDINARY 0 -#define CL_SPECIAL 1 -#define CL_CONSTANT 2 -#define SI_ORDINARY 4 -#define SI_SPECIAL 5 -#define KEYWORD 10 -#define FORM_ORDINARY 16 -#define MP_ORDINARY 12 -#define MP_SPECIAL 13 +#define CL_PACKAGE 0 +#define SI_PACKAGE 4 +#define KEYWORD_PACKAGE 8 +#define MP_PACKAGE 12 +#define ORDINARY_SYMBOL 0 +#define CONSTANT_SYMBOL 1 +#define SPECIAL_SYMBOL 2 +#define FORM_SYMBOL 3 + +#define CL_ORDINARY CL_PACKAGE | ORDINARY_SYMBOL +#define CL_SPECIAL CL_PACKAGE | SPECIAL_SYMBOL +#define CL_CONSTANT CL_PACKAGE | CONSTANT_SYMBOL +#define SI_ORDINARY SI_PACKAGE | ORDINARY_SYMBOL +#define SI_SPECIAL SI_PACKAGE | SPECIAL_SYMBOL +#define SI_CONSTANT SI_PACKAGE | CONSTANT_SYMBOL +#define MP_ORDINARY MP_PACKAGE | ORDINARY_SYMBOL +#define MP_SPECIAL MP_PACKAGE | SPECIAL_SYMBOL +#define MP_CONSTANT MP_PACKAGE | CONSTANT_SYMBOL +#define KEYWORD KEYWORD_PACKAGE | CONSTANT_SYMBOL +#define FORM_ORDINARY CL_PACKAGE | ORDINARY_SYMBOL | FORM_SYMBOL #include "symbols_list.h" @@ -143,18 +154,20 @@ make_this_symbol(int i, cl_object s, int code, const char *name, { enum ecl_stype stp; cl_object package; + bool form = 0; switch (code & 3) { - case 0: stp = stp_ordinary; break; - case 1: stp = stp_special; break; - case 2: stp = stp_constant; break; + case ORDINARY_SYMBOL: stp = stp_ordinary; break; + case SPECIAL_SYMBOL: stp = stp_special; break; + case CONSTANT_SYMBOL: stp = stp_constant; break; + case FORM_SYMBOL: form = 1; } switch (code & 12) { - case 0: package = cl_core.lisp_package; break; - case 4: package = cl_core.system_package; break; - case 8: package = cl_core.keyword_package; break; + case CL_PACKAGE: package = cl_core.lisp_package; break; + case SI_PACKAGE: package = cl_core.system_package; break; + case KEYWORD_PACKAGE: package = cl_core.keyword_package; break; #ifdef ECL_THREADS - case 12: package = cl_core.mp_package; break; + case MP_PACKAGE: package = cl_core.mp_package; break; #endif } s->symbol.t = t_symbol; @@ -177,9 +190,7 @@ make_this_symbol(int i, cl_object s, int code, const char *name, cl_import2(s, package); cl_export2(s, package); } - if (code == FORM_ORDINARY) - s->symbol.isform = TRUE; - else if (fun != NULL) { + if (!(s->symbol.isform = form) && fun) { cl_object f = cl_make_cfun_va(fun, s, NULL); SYM_FUN(s) = f; f->cfun.narg = narg; diff --git a/src/c/alloc.d b/src/c/alloc.d index 662ce8f0e..262988409 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -225,14 +225,6 @@ cl_alloc_object(cl_type t) start_critical_section(); tm = tm_of(t); ONCE_MORE: - if (interrupt_flag) { - interrupt_flag = FALSE; -#ifdef HAVE_ALARM - alarm(0); -#endif - terminal_interrupt(TRUE); - } - obj = tm->tm_free; if (obj == OBJNULL) { cl_index available = available_pages(); @@ -437,13 +429,6 @@ make_cons(cl_object a, cl_object d) start_critical_section(); ONCE_MORE: - if (interrupt_flag) { - interrupt_flag = FALSE; -#ifdef HAVE_ALARM - alarm(0); -#endif - terminal_interrupt(TRUE); - } obj = tm->tm_free; if (obj == OBJNULL) { if (tm->tm_npage >= tm->tm_maxpage) @@ -515,15 +500,7 @@ cl_alloc(cl_index n) n = round_up(n); start_critical_section(); - ONCE_MORE: - if (interrupt_flag) { - interrupt_flag = FALSE; - gg = g; - terminal_interrupt(TRUE); - g = gg; - } - /* Use extra indirection so that cb_pointer can be updated */ for (cbpp = &cb_pointer; (*cbpp) != NULL; cbpp = &(*cbpp)->cb_link) if ((*cbpp)->cb_size >= n) { diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index c61c73946..6bf215fe9 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -56,8 +56,7 @@ finalize(cl_object o, cl_object data) break; #ifdef ECL_THREADS case t_lock: - if (o->lock.mutex != NULL) - pthread_mutex_destroy(o->lock.mutex); + pthread_mutex_destroy(&o->lock.mutex); break; #endif default:} diff --git a/src/c/error.d b/src/c/error.d index 522c166d3..6d3658404 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -58,12 +58,6 @@ internal_error(const char *s) /* Support for Lisp Error Handler */ /*****************************************************************************/ -void -terminal_interrupt(bool correctable) -{ - funcall(2, @'si::terminal-interrupt', correctable? Ct : Cnil); -} - void FEerror(char *s, int narg, ...) { diff --git a/src/c/file.d b/src/c/file.d index ecf8fb0b8..eabe87375 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -1348,8 +1348,7 @@ BEGIN: cl_object si_file_column(cl_object strm) { - int c = file_column(strm); - @(return (c < 0? Cnil : MAKE_FIXNUM(c))) + @(return MAKE_FIXNUM(file_column(strm))) } int @@ -1359,14 +1358,14 @@ file_column(cl_object strm) BEGIN: #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) - return -1; + return 0; #endif if (type_of(strm) != t_stream) FEtype_error_stream(strm); switch ((enum ecl_smmode)strm->stream.mode) { case smm_closed: FEclosed_stream(strm); - return(-1); + return 0; case smm_output: case smm_io: @@ -1385,26 +1384,14 @@ BEGIN: case smm_input: case smm_probe: case smm_string_input: - return(-1); + return 0; case smm_concatenated: + case smm_broadcast: if (endp(strm->stream.object0)) - return(-1); + return 0; strm = CAR(strm->stream.object0); goto BEGIN; - - case smm_broadcast: - { - int i; - cl_object x; - - for (x = strm->stream.object0; !endp(x); x = CDR(x)) { - i = file_column(CAR(x)); - if (i >= 0) - return(i); - } - return(-1); - } default: error("illegal stream mode"); } diff --git a/src/c/gbc.d b/src/c/gbc.d index 7565b7963..da4be20c7 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -701,6 +701,7 @@ ecl_gc(cl_type new_name) { int tm; int gc_start = runtime(); + cl_object old_interrupt_enable; start_critical_section(); t = new_name; @@ -713,6 +714,7 @@ ecl_gc(cl_type t) int i, j; int tm; int gc_start = runtime(); + cl_object old_interrupt_enable; #endif /* THREADS */ if (!GC_enabled()) @@ -763,7 +765,7 @@ ecl_gc(cl_type t) if (GC_enter_hook != NULL) (*GC_enter_hook)(); - interrupt_enable = FALSE; + old_interrupt_enable = ecl_enable_interrupt(Cnil); collect_blocks = t > t_end; if (collect_blocks) @@ -850,7 +852,7 @@ ecl_gc(cl_type t) fflush(stdout); } - interrupt_enable = TRUE; + ecl_enable_interrupt(old_enable_interrupt); if (GC_exit_hook != NULL) (*GC_exit_hook)(); @@ -888,7 +890,7 @@ ecl_gc(cl_type t) fflush(stdout); } - if (interrupt_flag) sigint(); + if (cl_env.interrupts_pending) si_check_pending_interrupts(); end_critical_section(); } diff --git a/src/c/gfun.d b/src/c/gfun.d index 307a10d5c..cc8404a6d 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -91,7 +91,7 @@ set_meth_hash(cl_object *keys, int argno, cl_object hashtable, cl_object value) else FEerror("internal error, corrupted hashtable ~S", 1, hashtable); if (over) - extend_hashtable(hashtable); + ecl_extend_hashtable(hashtable); keylist = Cnil; for (p = keys + argno; p > keys; p--) keylist = CONS(p[-1], keylist); e = get_meth_hash(keys, argno, hashtable); diff --git a/src/c/hash.d b/src/c/hash.d index cddb8532b..3ef267fd4 100644 --- a/src/c/hash.d +++ b/src/c/hash.d @@ -16,6 +16,7 @@ #include "ecl.h" #include +#include "internal.h" /******************* * CRC-32 ROUTINES * @@ -229,7 +230,6 @@ ecl_search_hash(cl_object key, cl_object hashtable) int htest; bool b; - assert_type_hash_table(hashtable); htest = hashtable->hash.test; hsize = hashtable->hash.size; j = hsize; @@ -279,8 +279,13 @@ ecl_search_hash(cl_object key, cl_object hashtable) cl_object gethash(cl_object key, cl_object hashtable) { - /* INV: ecl_search_hash() checks the type of hashtable */ - return ecl_search_hash(key, hashtable)->value; + cl_object output; + + assert_type_hash_table(hashtable); + HASH_TABLE_LOCK(hashtable); + output = ecl_search_hash(key, hashtable)->value; + HASH_TABLE_UNLOCK(hashtable); + return output; } cl_object @@ -288,12 +293,13 @@ gethash_safe(cl_object key, cl_object hashtable, cl_object def) { struct ecl_hashtable_entry *e; - /* INV: ecl_search_hash() checks the type of hashtable */ + assert_type_hash_table(hashtable); + HASH_TABLE_LOCK(hashtable); e = ecl_search_hash(key, hashtable); - if (e->key == OBJNULL) - return def; - else - return e->value; + if (e->key != OBJNULL) + def = e->value; + HASH_TABLE_UNLOCK(hashtable); + return def; } static void @@ -336,11 +342,12 @@ sethash(cl_object key, cl_object hashtable, cl_object value) bool over; struct ecl_hashtable_entry *e; - /* INV: ecl_search_hash() checks the type of hashtable */ + assert_type_hash_table(hashtable); + HASH_TABLE_LOCK(hashtable); e = ecl_search_hash(key, hashtable); if (e->key != OBJNULL) { e->value = value; - return; + goto OUTPUT; } i = hashtable->hash.entries + 1; if (i >= hashtable->hash.size) @@ -351,15 +358,19 @@ sethash(cl_object key, cl_object hashtable, cl_object value) over = i >= hashtable->hash.size * sf(hashtable->hash.threshold); else if (type_of(hashtable->hash.threshold) == t_longfloat) over = i >= hashtable->hash.size * lf(hashtable->hash.threshold); - else + else { + HASH_TABLE_UNLOCK(hashtable); corrupted_hash(hashtable); + } if (over) - extend_hashtable(hashtable); + ecl_extend_hashtable(hashtable); add_new_to_hash(key, hashtable, value); + OUTPUT: + HASH_TABLE_UNLOCK(hashtable); } void -extend_hashtable(cl_object hashtable) +ecl_extend_hashtable(cl_object hashtable) { cl_object old, key; cl_index old_size, new_size, i; @@ -402,14 +413,16 @@ extend_hashtable(cl_object hashtable) @(defun make_hash_table (&key (test @'eql') (size MAKE_FIXNUM(1024)) (rehash_size make_shortfloat(1.5)) - (rehash_threshold make_shortfloat(0.7))) + (rehash_threshold make_shortfloat(0.7)) + (lockable Cnil)) @ - @(return cl__make_hash_table(test, size, rehash_size, rehash_threshold)) + @(return cl__make_hash_table(test, size, rehash_size, rehash_threshold, + lockable)) @) cl_object cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, - cl_object rehash_threshold) + cl_object rehash_threshold, cl_object lockable) { int htt; cl_index hsize; @@ -455,6 +468,11 @@ cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, h->hash.data = NULL; /* for GC sake */ h->hash.data = (struct ecl_hashtable_entry *) cl_alloc(hsize * sizeof(struct ecl_hashtable_entry)); + h->hash.lockable = !Null(lockable); +#ifdef ECL_THREADS + if (h->hash.lockable) + pthread_mutex_init(&h->hash.lock, NULL); +#endif return cl_clrhash(h); } @@ -465,12 +483,14 @@ cl_hash_table_p(cl_object ht) } @(defun gethash (key ht &optional (no_value Cnil)) - struct ecl_hashtable_entry *e; + struct ecl_hashtable_entry e; @ - /* INV: ecl_search_hash() checks the type of hashtable */ - e = ecl_search_hash(key, ht); - if (e->key != OBJNULL) - @(return e->value Ct) + assert_type_hash_table(ht); + HASH_TABLE_LOCK(ht); + e = *ecl_search_hash(key, ht); + HASH_TABLE_UNLOCK(ht); + if (e.key != OBJNULL) + @(return e.value Ct) else @(return no_value Cnil) @) @@ -487,16 +507,21 @@ bool remhash(cl_object key, cl_object hashtable) { struct ecl_hashtable_entry *e; + bool output; - /* INV: ecl_search_hash() checks the type of hashtable */ + assert_type_hash_table(hashtable); + HASH_TABLE_LOCK(hashtable); e = ecl_search_hash(key, hashtable); - if (e->key != OBJNULL) { + if (e->key == OBJNULL) { + output = FALSE; + } else { e->key = OBJNULL; e->value = Cnil; hashtable->hash.entries--; - return TRUE; + output = TRUE; } - return FALSE; + HASH_TABLE_UNLOCK(hashtable); + return output; } cl_object @@ -512,11 +537,13 @@ cl_clrhash(cl_object ht) cl_index i; assert_type_hash_table(ht); + HASH_TABLE_LOCK(ht); for(i = 0; i < ht->hash.size; i++) { ht->hash.data[i].key = OBJNULL; ht->hash.data[i].value = OBJNULL; } ht->hash.entries = 0; + HASH_TABLE_UNLOCK(ht); @(return ht) } @@ -529,7 +556,8 @@ cl_hash_table_test(cl_object ht) case htt_eql: output = @'eql'; break; case htt_equal: output = @'equal'; break; case htt_equalp: output = @'equalp'; break; - default: output = Cnil; + case htt_pack: + default: output = @'equal'; } @(return output) } @@ -557,12 +585,14 @@ si_hash_table_iterate(int narg, cl_object env) i = fix(index); if (i < 0) i = -1; - for (; ++i < ht->hash.size; ) - if (ht->hash.data[i].key != OBJNULL) { + for (; ++i < ht->hash.size; ) { + struct ecl_hashtable_entry e = ht->hash.data[i]; + if (e.key != OBJNULL) { @(return (CAR(env) = MAKE_FIXNUM(i)) - ht->hash.data[i].key - ht->hash.data[i].value) + e.key + e.value) } + } CAR(env) = Cnil; } @(return Cnil) @@ -602,10 +632,9 @@ cl_maphash(cl_object fun, cl_object ht) assert_type_hash_table(ht); for (i = 0; i < ht->hash.size; i++) { - if(ht->hash.data[i].key != OBJNULL) - funcall(3, fun, - ht->hash.data[i].key, - ht->hash.data[i].value); + struct ecl_hashtable_entry e = ht->hash.data[i]; + if(e.key != OBJNULL) + funcall(3, fun, e.key, e.value); } @(return Cnil) } @@ -617,9 +646,12 @@ si_copy_hash_table(cl_object orig) hash = cl__make_hash_table(cl_hash_table_test(orig), cl_hash_table_size(orig), cl_hash_table_rehash_size(orig), - cl_hash_table_rehash_threshold(orig)); + cl_hash_table_rehash_threshold(orig), + orig->hash.lockable? Ct : Cnil); + HASH_TABLE_LOCK(hash); memcpy(hash->hash.data, orig->hash.data, orig->hash.size * sizeof(*orig->hash.data)); hash->hash.entries = orig->hash.entries; + HASH_TABLE_UNLOCK(hash); @(return hash) } diff --git a/src/c/list.d b/src/c/list.d index 845da2cbc..e7726d361 100644 --- a/src/c/list.d +++ b/src/c/list.d @@ -849,6 +849,24 @@ error: FEerror("The keys ~S and the data ~S are not of the same length", @(return a_list) @) +void +ecl_delete_eq(cl_object x, cl_object *lp) +{ + for (; CONSP(*lp); lp = &CDR((*lp))) + if (CAR((*lp)) == x) { + *lp = CDR((*lp)); + return; + } +} + +cl_object +ecl_remove_eq(cl_object x, cl_object l) +{ + l = cl_copy_list(l); + ecl_delete_eq(x, &l); + return l; +} + /* Added for use by the compiler, instead of open coding them. Beppe */ cl_object assq(cl_object x, cl_object l) diff --git a/src/c/load.d b/src/c/load.d index 70da361ec..c97731328 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -105,6 +105,7 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print) cl_object block; cl_object basename; cl_object prefix; + cl_object output; /* A full garbage collection enables us to detect unused code and leave space for the library to be loaded. */ @@ -113,10 +114,19 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print) /* We need the full pathname */ filename = coerce_to_filename(cl_truename(filename)); +#ifdef ECL_THREADS + /* Loading binary code is not thread safe. When another thread tries + to load the same file, we may end up initializing twice the same + module. */ + mp_get_lock(1, symbol_value(@'mp::+load-compile-lock+')); + CL_UNWIND_PROTECT_BEGIN { +#endif /* Try to load shared object file */ block = ecl_library_open(filename); - if (block->cblock.handle == NULL) - @(return ecl_library_error(block)) + if (block->cblock.handle == NULL) { + output = ecl_library_error(block); + goto OUTPUT; + } /* Fist try to call "init_CODE()" */ block->cblock.entry = ecl_library_symbol(block, INIT_PREFIX "CODE"); @@ -138,15 +148,22 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print) block->cblock.entry = ecl_library_symbol(block, basename->string.self); if (block->cblock.entry == NULL) { - cl_object output = ecl_library_error(block); + output = ecl_library_error(block); ecl_library_close(block); - @(return output) + goto OUTPUT; } /* Finally, perform initialization */ GO_ON: read_VV(block, block->cblock.entry); - @(return Cnil) + output = Cnil; +OUTPUT: +#ifdef ECL_THREADS + } CL_UNWIND_PROTECT_EXIT { + mp_giveup_lock(symbol_value(@'mp::+load-compile-lock+')); + } CL_UNWIND_PROTECT_END; +#endif + @(return output) } #endif /* ENABLE_DLOPEN */ diff --git a/src/c/main.d b/src/c/main.d index 6520e1259..923ab38c2 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -82,7 +82,7 @@ ecl_init_env(struct cl_env_struct *env) env->circle_counter = -2; env->circle_stack = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), make_shortfloat(1.5), - make_shortfloat(0.7)); + make_shortfloat(0.7), Cnil); #ifndef ECL_CMU_FORMAT env->fmt_aux_stream = make_string_output_stream(64); #endif @@ -215,7 +215,8 @@ cl_boot(int argc, char **argv) cl_core.system_properties = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), /* size */ make_shortfloat(1.5), /* rehash-size */ - make_shortfloat(0.7)); /* rehash-threshold */ + make_shortfloat(0.7), /* rehash-threshold */ + Ct); /* thread-safe */ cl_core.gensym_prefix = make_simple_string("G"); cl_core.gentemp_prefix = make_simple_string("T"); @@ -233,7 +234,9 @@ cl_boot(int argc, char **argv) #ifdef ECL_THREADS cl_env.bindings_hash = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), make_shortfloat(1.5), - make_shortfloat(0.7)); + make_shortfloat(0.7), + Cnil); /* no locking */ + ECL_SET(@'mp::*current-process*', cl_env.own_process); #endif /* @@ -254,6 +257,10 @@ cl_boot(int argc, char **argv) /* * 5) Set up hooks for LOAD, errors and macros. */ +#ifdef ECL_THREADS + ECL_SET(@'mp::+load-compile-lock+', + mp_make_lock(2, @':name', @'mp::+load-compile-lock+')); +#endif ECL_SET(@'si::*load-hooks*', cl_list( #ifdef ENABLE_DLOPEN 4,CONS(make_simple_string("fas"), @'si::load-binary'), @@ -276,7 +283,8 @@ cl_boot(int argc, char **argv) ECL_SET(@'si::*class-name-hash-table*', cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), /* size */ make_shortfloat(1.5), /* rehash-size */ - make_shortfloat(0.7))); /* rehash-threshold */ + make_shortfloat(0.7), /* rehash-threshold */ + Ct)); /* thread safe */ #endif /* @@ -350,7 +358,7 @@ cl_boot(int argc, char **argv) /* Jump to top level */ ECL_SET(@'*package*', cl_core.user_package); - enable_interrupt(); + init_unixint(); si_catch_bad_signals(); } diff --git a/src/c/num_arith.d b/src/c/num_arith.d index 11016cdf4..fccc4f75e 100644 --- a/src/c/num_arith.d +++ b/src/c/num_arith.d @@ -289,7 +289,7 @@ number_plus(cl_object x, cl_object y) case t_shortfloat: return make_shortfloat(number_to_double(x) + sf(y)); case t_longfloat: - return make_shortfloat(number_to_double(x) + lf(y)); + return make_longfloat(number_to_double(x) + lf(y)); case t_complex: goto COMPLEX; default: @@ -387,7 +387,7 @@ number_minus(cl_object x, cl_object y) case t_shortfloat: return make_shortfloat(fix(x) - sf(y)); case t_longfloat: - return make_shortfloat(fix(x) - lf(y)); + return make_longfloat(fix(x) - lf(y)); case t_complex: goto COMPLEX; default: @@ -524,11 +524,14 @@ number_negate(cl_object x) switch (type_of(x)) { case t_fixnum: { cl_fixnum k = fix(x); - /* -MOST_NEGATIVE_FIXNUM > MOST_POSITIVE_FIXNUM */ - if (k == MOST_NEGATIVE_FIXNUM) + if (-MOST_NEGATIVE_FIXNUM > MOST_POSITIVE_FIXNUM) { + if (k == MOST_NEGATIVE_FIXNUM) return(bignum1(- MOST_NEGATIVE_FIXNUM)); - else + else return(MAKE_FIXNUM(-k)); + } else { + return MAKE_FIXNUM(-k); + } } case t_bignum: z = big_register0_get(); @@ -695,8 +698,21 @@ integer_divide(cl_object x, cl_object y) if (tx == t_fixnum) { if (ty == t_fixnum) return MAKE_FIXNUM(fix(x) / fix(y)); - if (ty == t_bignum) - return MAKE_FIXNUM(0); + if (ty == t_bignum) { + /* The only number "x" which can be a bignum and be + * as large as "-x" is -MOST_NEGATIVE_FIXNUM. However + * in newer versions of ECL we will probably choose + * MOST_NEGATIVE_FIXNUM = - MOST_POSITIVE_FIXNUM. + */ + if (-MOST_NEGATIVE_FIXNUM > MOST_POSITIVE_FIXNUM) { + if (mpz_cmp_si(y->big.big_num, -fix(x))) + return MAKE_FIXNUM(0); + else + return MAKE_FIXNUM(-1); + } else { + return MAKE_FIXNUM(0); + } + } FEtype_error_integer(y); } if (tx == t_bignum) { diff --git a/src/c/num_co.d b/src/c/num_co.d index f58c2e641..07a60e4ca 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -102,11 +102,11 @@ number_remainder(cl_object x, cl_object y, cl_object q) break; } case t_shortfloat: - if (t == t_longfloat) + if (y && t == t_longfloat) x = make_longfloat(sf(x)); break; case t_longfloat: - if (t == t_shortfloat) + if (y && t == t_shortfloat) x = make_shortfloat(lf(x)); break; default: @@ -634,34 +634,9 @@ round2(cl_object x, cl_object y) VALUES(1) = number_remainder(x, y, q1); break; } - case t_shortfloat: { - float d = sf(q); - float aux = d + (d >= 0.0 ? 0.5 : -0.5); - cl_object q1 = float_to_integer(aux); - d -= aux; - if (d == 0.5 && number_oddp(q1)) - q1 = one_plus(q1); - if (d == -0.5 && number_oddp(q1)) - q1 = one_minus(q1); - VALUES(0) = q1; - VALUES(1) = number_remainder(x, y, q1); - break; - } - case t_longfloat: { - double d = lf(q); - double aux = d + (d >= 0.0 ? 0.5 : -0.5); - cl_object q1 = double_to_integer(aux); - d -= aux; - if (d == 0.5 && number_oddp(q1)) - q1 = one_plus(q1); - if (d == -0.5 && number_oddp(q1)) - q1 = one_minus(q1); - VALUES(0) = q1; - VALUES(1) = number_remainder(x, y, q1); - break; - } default: - FEerror("Complex arguments to round2 (~S, ~S)", 2, x, y); + VALUES(0) = q = round1(q); + VALUES(1) = number_remainder(x, y, q); } NVALUES = 2; return VALUES(0); diff --git a/src/c/num_comp.d b/src/c/num_comp.d index 8b506e4b3..9d664e2ba 100644 --- a/src/c/num_comp.d +++ b/src/c/num_comp.d @@ -77,7 +77,7 @@ number_equalp(cl_object x, cl_object y) return 0; case t_ratio: return (number_equalp(x->ratio.num, y->ratio.num) && - number_equalp(x->ratio.den, x->ratio.den)); + number_equalp(x->ratio.den, y->ratio.den)); case t_shortfloat: return sf(y) == number_to_double(x); case t_longfloat: diff --git a/src/c/package.d b/src/c/package.d index f631f77a5..ce4a4cda1 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -14,11 +14,22 @@ See file '../Copyright' for full details. */ - #include "ecl.h" #include "internal.h" /******************************* ------- ******************************/ +/* + * NOTE 1: we only need to use the package locks when reading/writing the hash + * tables, or changing the fields of a package. We do not need the locks to + * read lists from the packages (i.e. list of shadowing symbols, used + * packages, etc), or from the global environment (cl_core.packages_list) if + * we do not destructively modify them (For instance, use ecl_remove_eq + * instead of ecl_delete_eq). + */ +/* + * NOTE 2: Operations between locks must be guaranteed not fail, or, if + * they signal an error, they should undo all locks they had before. + */ #define INTERNAL 1 #define EXTERNAL 2 @@ -75,6 +86,7 @@ make_package_hashtable() cl_index hsize = 128; h = cl_alloc_object(t_hashtable); + h->hash.lockable = 0; h->hash.test = htt_pack; h->hash.size = hsize; h->hash.rehash_size = make_shortfloat(1.5); @@ -94,6 +106,10 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list) assert_type_proper_list(nicknames); assert_type_proper_list(use_list); + /* 1) Find a similarly named package in the list of packages to be + * created and use it. + */ + PACKAGE_OP_LOCK(); if (cl_core.packages_to_be_created != OBJNULL) { cl_object *p = &cl_core.packages_to_be_created; for (x = *p; x != Cnil; ) { @@ -102,12 +118,16 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list) x = CDAR(x); goto INTERN; } + /* FIXME! We should also check the nicknames */ p = &CDR(x); x = *p; } } - if ((other = find_package(name)) != Cnil) { - ERROR: cl_cerror(8, + + /* 2) Otherwise, try to build a new package */ + if ((other = ecl_find_package_nolock(name)) != Cnil) { + ERROR: PACKAGE_OP_UNLOCK(); + cl_cerror(8, make_simple_string("Return existing package"), @'si::simple-package-error', @':format-control', @@ -120,6 +140,19 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list) x->pack.internal = make_package_hashtable(); x->pack.external = make_package_hashtable(); x->pack.name = name; +#ifdef ECL_THREADS +#if 0 + pthread_mutex_init(&x->pack.lock); +#else + { + pthread_mutexattr_t attr; + pthread_mutexattr_init(&attr); + pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_ERRORCHECK_NP); + pthread_mutex_init(&x->pack.lock, &attr); + pthread_mutexattr_destroy(&attr); + } +#endif +#endif INTERN: x->pack.nicknames = Cnil; x->pack.shadowings = Cnil; @@ -128,7 +161,7 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list) x->pack.locked = FALSE; for (; !endp(nicknames); nicknames = CDR(nicknames)) { cl_object nick = cl_string(CAR(nicknames)); - if ((other = find_package(nick)) != Cnil) { + if ((other = ecl_find_package_nolock(nick)) != Cnil) { name = nick; goto ERROR; } @@ -139,7 +172,10 @@ make_package(cl_object name, cl_object nicknames, cl_object use_list) x->pack.uses = CONS(y, x->pack.uses); y->pack.usedby = CONS(x, y->pack.usedby); } + + /* 3) Finally, add it to the list of packages */ cl_core.packages = CONS(x, cl_core.packages); + PACKAGE_OP_UNLOCK(); return(x); } @@ -148,20 +184,16 @@ rename_package(cl_object x, cl_object name, cl_object nicknames) { cl_object y; - /* - If we are trying to rename the package with either its name - or a nickname, then we are really trying to redefine the - package. Therefore, do not signal the error. - - Marco Antoniotti 19951028 - */ + name = cl_string(name); x = si_coerce_to_package(x); if (x->pack.locked) CEpackage_error("Cannot rename locked package ~S.", x, 0); - name = cl_string(name); - y = find_package(name); + + PACKAGE_OP_LOCK(); + y = ecl_find_package_nolock(name); if ((y != Cnil) && (y != x)) { - ERROR: FEpackage_error("A package with name ~S already exists.", x, + ERROR: PACKAGE_OP_UNLOCK(); + FEpackage_error("A package with name ~S already exists.", x, 1, name); } @@ -170,7 +202,7 @@ rename_package(cl_object x, cl_object name, cl_object nicknames) assert_type_proper_list(nicknames); for (; !endp(nicknames); nicknames = CDR(nicknames)) { cl_object nick = CAR(nicknames); - y = find_package(nick); + y = ecl_find_package_nolock(nick); if (x == y) continue; if (y != Cnil) { @@ -179,16 +211,23 @@ rename_package(cl_object x, cl_object name, cl_object nicknames) } x->pack.nicknames = CONS(cl_string(nick), x->pack.nicknames); } + PACKAGE_OP_UNLOCK(); return(x); } /* - Find_package(n) seaches for a package with name n, where n is + ecl_find_package_nolock(n) seaches for a package with name n, where n is a valid string designator, or simply outputs n if it is a package. + + This is not a locking routine and someone may replace the list of + packages while we are scanning it. Nevertheless, the list IS NOT + be destructively modified, which means that we are on the safe side. + Routines which need to ensure that the package list remains constant + should enforce a global lock with PACKAGE_OP_LOCK(). */ cl_object -find_package(cl_object name) +ecl_find_package_nolock(cl_object name) { cl_object l, p; @@ -209,9 +248,9 @@ find_package(cl_object name) cl_object si_coerce_to_package(cl_object p) { - /* INV: find_package() signals an error if "p" is neither a package + /* INV: ecl_find_package_nolock() signals an error if "p" is neither a package nor a string */ - cl_object pp = find_package(p); + cl_object pp = ecl_find_package_nolock(p); if (Null(pp)) { FEpackage_error("There exists no package with name ~S", p, 0); } @@ -250,29 +289,34 @@ intern(cl_object name, cl_object p, int *intern_flag) assert_type_string(name); p = si_coerce_to_package(p); + TRY_AGAIN: + PACKAGE_LOCK(p); s = gethash_safe(name, p->pack.external, OBJNULL); if (s != OBJNULL) { *intern_flag = EXTERNAL; - return s; + goto OUTPUT; } /* Keyword package has no intern section nor can it be used */ if (p == cl_core.keyword_package) goto INTERN; s = gethash_safe(name, p->pack.internal, OBJNULL); if (s != OBJNULL) { *intern_flag = INTERNAL; - return s; + goto OUTPUT; } for (ul=p->pack.uses; CONSP(ul); ul = CDR(ul)) { s = gethash_safe(name, CAR(ul)->pack.external, OBJNULL); if (s != OBJNULL) { *intern_flag = INHERITED; - return s; + goto OUTPUT; } } INTERN: - if (p->pack.locked) + if (p->pack.locked) { + PACKAGE_UNLOCK(p); CEpackage_error("Cannot intern symbol ~S in locked package ~S.", p, 2, name, p); + goto TRY_AGAIN; + } s = make_symbol(name); s->symbol.hpack = p; *intern_flag = 0; @@ -283,100 +327,112 @@ intern(cl_object name, cl_object p, int *intern_flag) } else { sethash(name, p->pack.internal, s); } + OUTPUT: + PACKAGE_UNLOCK(p); return s; } /* - Find_symbol(st, len, p) searches for string st of length len in package p. + ecl_find_symbol_nolock(st, len, p) searches for string st of length + len in package p. */ cl_object -find_symbol(cl_object name, cl_object p, int *intern_flag) +ecl_find_symbol_nolock(cl_object name, cl_object p, int *intern_flag) { cl_object s, ul; - - name = cl_string(name); - p = si_coerce_to_package(p); + + assert_type_string(name); s = gethash_safe(name, p->pack.external, OBJNULL); if (s != OBJNULL) { *intern_flag = EXTERNAL; - return s; + goto OUTPUT; } - if (p == cl_core.keyword_package) goto RETURN; + if (p == cl_core.keyword_package) + goto NOTHING; s = gethash_safe(name, p->pack.internal, OBJNULL); if (s != OBJNULL) { *intern_flag = INTERNAL; - return s; + goto OUTPUT; } for (ul=p->pack.uses; CONSP(ul); ul = CDR(ul)) { s = gethash_safe(name, CAR(ul)->pack.external, OBJNULL); if (s != OBJNULL) { *intern_flag = INHERITED; - return s; + goto OUTPUT; } } -RETURN: + NOTHING: *intern_flag = 0; - return(Cnil); + s = Cnil; + OUTPUT: + return s; } -static void -delete_eq(cl_object x, cl_object *lp) +#ifdef ECL_THREADS +cl_object +ecl_find_symbol(cl_object n, cl_object p, int *intern_flag) { - for (; CONSP(*lp); lp = &CDR((*lp))) - if (CAR((*lp)) == x) { - *lp = CDR((*lp)); - return; - } + n = cl_string(n); + p = si_coerce_to_package(p); + PACKAGE_LOCK(p); + n = ecl_find_symbol_nolock(n, p, intern_flag); + PACKAGE_UNLOCK(p); + return n; } +#endif bool unintern(cl_object s, cl_object p) { cl_object x, y, l, hash; + bool output = FALSE; assert_type_symbol(s); p = si_coerce_to_package(p); + + TRY_AGAIN: + PACKAGE_LOCK(p); hash = p->pack.internal; x = gethash_safe(s->symbol.name, hash, OBJNULL); - if (x == s) { - if (member_eq(s, p->pack.shadowings)) - goto L; + if (x == s) goto UNINTERN; - } hash = p->pack.external; x = gethash_safe(s->symbol.name, hash, OBJNULL); - if (x == s) { - if (member_eq(s, p->pack.shadowings)) - goto L; - goto UNINTERN; - } - return(FALSE); - -L: - if (p->pack.locked) + if (x != s) + goto OUTPUT; + UNINTERN: + if (p->pack.locked) { + PACKAGE_UNLOCK(p); CEpackage_error("Cannot unintern symbol ~S from locked package ~S.", p, 2, s, p); + goto TRY_AGAIN; + } + if (!member_eq(s, p->pack.shadowings)) + goto NOT_SHADOW; x = OBJNULL; for (l = p->pack.uses; CONSP(l); l = CDR(l)) { y = gethash_safe(s->symbol.name, CAR(l)->pack.external, OBJNULL); if (y != OBJNULL) { if (x == OBJNULL) x = y; - else if (x != y) - FEpackage_error( -"Cannot unintern the shadowing symbol ~S~%\ -from ~S,~%\ -because ~S and ~S will cause~%\ -a name conflict.", p, 4, s, p, x, y); + else if (x != y) { + PACKAGE_UNLOCK(p); + FEpackage_error("Cannot unintern the shadowing symbol ~S~%" + "from ~S,~%" + "because ~S and ~S will cause~%" + "a name conflict.", p, 4, s, p, x, y); + } } } - delete_eq(s, &p->pack.shadowings); - -UNINTERN: + p->pack.shadowings = ecl_remove_eq(s, p->pack.shadowings); + NOT_SHADOW: remhash(s->symbol.name, hash); if (s->symbol.hpack == p) s->symbol.hpack = Cnil; - return(TRUE); + output = TRUE; + OUTPUT: + PACKAGE_UNLOCK(p); + return output; } void @@ -384,36 +440,47 @@ cl_export2(cl_object s, cl_object p) { cl_object x, l, hash = OBJNULL; int intern_flag; -BEGIN: + BEGIN: assert_type_symbol(s); p = si_coerce_to_package(p); + if (p->pack.locked) CEpackage_error("Cannot export symbol ~S from locked package ~S.", p, 2, s, p); - x = find_symbol(s, p, &intern_flag); - if (!intern_flag) + PACKAGE_LOCK(p); + x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag); + if (!intern_flag) { + PACKAGE_UNLOCK(p); FEpackage_error("The symbol ~S is not accessible from ~S.", p, 2, s, p); + } if (x != s) { - cl_import2(s, p); /* signals an error */ - goto BEGIN; + PACKAGE_UNLOCK(p); + FEpackage_error("Cannot export the symbol ~S~%" + "from ~S,~%" + "because there is already a symbol with the same name~%" + "in the package.", p, 2, s, p); } if (intern_flag == EXTERNAL) - return; + goto OUTPUT; if (intern_flag == INTERNAL) hash = p->pack.internal; for (l = p->pack.usedby; CONSP(l); l = CDR(l)) { - x = find_symbol(s, CAR(l), &intern_flag); + x = ecl_find_symbol_nolock(s->symbol.name, CAR(l), &intern_flag); if (intern_flag && s != x && - !member_eq(x, CAR(l)->pack.shadowings)) - FEpackage_error("Cannot export the symbol ~S~%\ -from ~S,~%\ -because it will cause a name conflict~%\ -in ~S.", p, 3, s, p, CAR(l)); + !member_eq(x, CAR(l)->pack.shadowings)) { + PACKAGE_UNLOCK(p); + FEpackage_error("Cannot export the symbol ~S~%" + "from ~S,~%" + "because it will cause a name conflict~%" + "in ~S.", p, 3, s, p, CAR(l)); + } } if (hash != OBJNULL) remhash(s->symbol.name, hash); sethash(s->symbol.name, p->pack.external, s); + OUTPUT: + PACKAGE_UNLOCK(p); } cl_object @@ -421,31 +488,53 @@ cl_delete_package(cl_object p) { cl_object hash, list; cl_index i; + cl_object output = Ct; - p = find_package(p); + /* 1) Try to remove the package from the global list */ + p = ecl_find_package_nolock(p); if (Null(p)) { CEpackage_error("Package ~S not found. Cannot delete it.", p, 0); @(return Cnil); } if (p->pack.locked) CEpackage_error("Cannot delete locked package ~S.", p, 0); - if (Null(p->pack.name)) - @(return Cnil) - if (p == cl_core.lisp_package || p == cl_core.keyword_package) + if (p == cl_core.lisp_package || p == cl_core.keyword_package) { FEpackage_error("Cannot remove package ~S", p, 0); + } + + /* 2) Now remove the package from the other packages that use it + * and empty the package. + */ + if (Null(p->pack.name)) { + @(return Cnil) + } for (list = p->pack.uses; !endp(list); list = CDR(list)) unuse_package(CAR(list), p); for (list = p->pack.usedby; !endp(list); list = CDR(list)) unuse_package(p, CAR(list)); + PACKAGE_LOCK(p); for (hash = p->pack.internal, i = 0; i < hash->hash.size; i++) - if (hash->hash.data[i].key != OBJNULL) - unintern(hash->hash.data[i].value, p); + if (hash->hash.data[i].key != OBJNULL) { + cl_object s = hash->hash.data[i].value; + if (s->symbol.hpack == p) + s->symbol.hpack = Cnil; + } + cl_clrhash(p->pack.internal); for (hash = p->pack.external, i = 0; i < hash->hash.size; i++) - if (hash->hash.data[i].key != OBJNULL) - unintern(hash->hash.data[i].value, p); - delete_eq(p, &cl_core.packages); + if (hash->hash.data[i].key != OBJNULL) { + cl_object s = hash->hash.data[i].value; + if (s->symbol.hpack == p) + s->symbol.hpack = Cnil; + } + cl_clrhash(p->pack.external); p->pack.shadowings = Cnil; p->pack.name = Cnil; + PACKAGE_UNLOCK(p); + + /* 2) Only at the end, remove the package from the list of packages. */ + PACKAGE_OP_LOCK(); + cl_core.packages = ecl_remove_eq(p, cl_core.packages); + PACKAGE_OP_UNLOCK(); @(return Ct) } @@ -463,16 +552,22 @@ cl_unexport2(cl_object s, cl_object p) if (p->pack.locked) CEpackage_error("Cannot unexport symbol ~S from locked package ~S.", p, 2, s, p); - x = find_symbol(s, p, &intern_flag); - if (intern_flag == 0) + PACKAGE_LOCK(p); + x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag); + if (intern_flag == 0) { + PACKAGE_UNLOCK(p); FEpackage_error("Cannot unexport ~S because it does not belong to package ~S.", p, 2, s, p); - if (intern_flag != EXTERNAL) + } + if (intern_flag != EXTERNAL) { /* According to ANSI & Cltl, internal symbols are ignored in unexport */ - return; - remhash(s->symbol.name, p->pack.external); - sethash(s->symbol.name, p->pack.internal, s); + (void)0; + } else { + remhash(s->symbol.name, p->pack.external); + sethash(s->symbol.name, p->pack.internal, s); + } + PACKAGE_UNLOCK(p); } void @@ -486,19 +581,24 @@ cl_import2(cl_object s, cl_object p) if (p->pack.locked) CEpackage_error("Cannot import symbol ~S into locked package ~S.", p, 2, s, p); - x = find_symbol(s, p, &intern_flag); + PACKAGE_LOCK(p); + x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag); if (intern_flag) { - if (x != s) - FEpackage_error("Cannot import the symbol ~S~%\ -from ~S,~%\ -because there is already a symbol with the same name~%\ -in the package.", p, 2, s, p); + if (x != s) { + PACKAGE_UNLOCK(p); + FEpackage_error("Cannot import the symbol ~S~%" + "from ~S,~%" + "because there is already a symbol with the same name~%" + "in the package.", p, 2, s, p); + } if (intern_flag == INTERNAL || intern_flag == EXTERNAL) - return; + goto OUTPUT; } sethash(s->symbol.name, p->pack.internal, s); if (Null(s->symbol.hpack)) s->symbol.hpack = p; + OUTPUT: + PACKAGE_UNLOCK(p); } void @@ -512,16 +612,18 @@ shadowing_import(cl_object s, cl_object p) if (p->pack.locked) CEpackage_error("Cannot shadowing-import symbol ~S into locked package ~S.", p, 2, s, p); - x = find_symbol(s, p, &intern_flag); + + PACKAGE_LOCK(p); + x = ecl_find_symbol_nolock(s->symbol.name, p, &intern_flag); if (intern_flag && intern_flag != INHERITED) { if (x == s) { if (!member_eq(x, p->pack.shadowings)) p->pack.shadowings = CONS(x, p->pack.shadowings); - return; + goto OUTPUT; } if(member_eq(x, p->pack.shadowings)) - delete_eq(x, &p->pack.shadowings); + p->pack.shadowings = ecl_remove_eq(x, p->pack.shadowings); if (intern_flag == INTERNAL) remhash(x->symbol.name, p->pack.internal); else @@ -531,6 +633,8 @@ shadowing_import(cl_object s, cl_object p) } p->pack.shadowings = CONS(s, p->pack.shadowings); sethash(s->symbol.name, p->pack.internal, s); + OUTPUT: + PACKAGE_UNLOCK(p); } void @@ -545,13 +649,15 @@ shadow(cl_object s, cl_object p) if (p->pack.locked) CEpackage_error("Cannot shadow symbol ~S in locked package ~S.", p, 2, s, p); - x = find_symbol(s, p, &intern_flag); + PACKAGE_LOCK(p); + x = ecl_find_symbol_nolock(s, p, &intern_flag); if (intern_flag != INTERNAL && intern_flag != EXTERNAL) { x = make_symbol(s); sethash(x->symbol.name, p->pack.internal, x); x->symbol.hpack = p; } p->pack.shadowings = CONS(x, p->pack.shadowings); + PACKAGE_UNLOCK(p); } void @@ -574,21 +680,29 @@ use_package(cl_object x, cl_object p) return; if (member_eq(x, p->pack.uses)) return; + + PACKAGE_LOCK(x); + PACKAGE_LOCK(p); hash_entries = x->pack.external->hash.data; hash_length = x->pack.external->hash.size; for (i = 0; i < hash_length; i++) if (hash_entries[i].key != OBJNULL) { cl_object here = hash_entries[i].value; - cl_object there = find_symbol(here, p, &intern_flag); + cl_object there = ecl_find_symbol_nolock(here->symbol.name, p, &intern_flag); if (intern_flag && here != there - && ! member_eq(there, p->pack.shadowings)) -FEpackage_error("Cannot use ~S~%\ -from ~S,~%\ -because ~S and ~S will cause~%\ -a name conflict.", p, 4, x, p, here, there); + && ! member_eq(there, p->pack.shadowings)) { + PACKAGE_UNLOCK(x); + PACKAGE_UNLOCK(p); + FEpackage_error("Cannot use ~S~%" + "from ~S,~%" + "because ~S and ~S will cause~%" + "a name conflict.", p, 4, x, p, here, there); + } } p->pack.uses = CONS(x, p->pack.uses); x->pack.usedby = CONS(p, x->pack.usedby); + PACKAGE_UNLOCK(x); + PACKAGE_UNLOCK(p); } void @@ -599,8 +713,12 @@ unuse_package(cl_object x, cl_object p) if (p->pack.locked) CEpackage_error("Cannot unuse package ~S from locked package ~S.", p, 2, x, p); - delete_eq(x, &p->pack.uses); - delete_eq(p, &x->pack.usedby); + PACKAGE_LOCK(x); + PACKAGE_LOCK(p); + p->pack.uses = ecl_remove_eq(x, p->pack.uses); + x->pack.usedby = ecl_remove_eq(p, x->pack.usedby); + PACKAGE_UNLOCK(p); + PACKAGE_UNLOCK(x); } @(defun make_package (pack_name &key nicknames (use CONS(cl_core.lisp_package, Cnil))) @@ -619,7 +737,7 @@ si_select_package(cl_object pack_name) cl_object cl_find_package(cl_object p) { - @(return find_package(p)) + @(return ecl_find_package_nolock(p)) } cl_object @@ -647,25 +765,19 @@ cl_package_nicknames(cl_object p) cl_object cl_package_use_list(cl_object p) { - /* FIXME: list should be a fresh one */ - p = si_coerce_to_package(p); - @(return p->pack.uses) + return cl_copy_list(si_coerce_to_package(p)->pack.uses); } cl_object cl_package_used_by_list(cl_object p) { - /* FIXME: list should be a fresh one */ - p = si_coerce_to_package(p); - @(return p->pack.usedby) + return cl_copy_list(si_coerce_to_package(p)->pack.usedby); } cl_object cl_package_shadowing_symbols(cl_object p) { - /* FIXME: list should be a fresh one */ - p = si_coerce_to_package(p); - @(return p->pack.shadowings) + return cl_copy_list(si_coerce_to_package(p)->pack.shadowings); } cl_object @@ -699,7 +811,7 @@ cl_list_all_packages() cl_object x; int intern_flag; @ - x = find_symbol(strng, p, &intern_flag); + x = ecl_find_symbol(strng, p, &intern_flag); if (intern_flag == INTERNAL) @(return x @':internal') if (intern_flag == EXTERNAL) @@ -893,6 +1005,12 @@ BEGIN: cl_object si_package_hash_tables(cl_object p) { + cl_object he, hi, u; assert_type_package(p); - @(return p->pack.external p->pack.internal p->pack.uses) + PACKAGE_LOCK(p); + he = si_copy_hash_table(p->pack.external); + hi = si_copy_hash_table(p->pack.internal); + u = cl_copy_list(p->pack.uses); + PACKAGE_UNLOCK(p); + @(return he hi u) } diff --git a/src/c/print.d b/src/c/print.d index 896591ff4..327d47f78 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -64,15 +64,6 @@ stream_or_default_output(cl_object stream) return stream; } -static void -writec_PRINTstream(int c) -{ - if (c == INDENT || c == INDENT1) - writec_stream(' ', cl_env.print_stream); - else if (c < 0400) - writec_stream(c, cl_env.print_stream); -} - static void writec_queue(int c) { @@ -93,7 +84,9 @@ flush_queue(bool force) BEGIN: while (cl_env.qc > 0) { c = cl_env.queue[cl_env.qh]; - if (c == MARK) + if (c < 0400) { + writec_stream(c, cl_env.print_stream); + } else if (c == MARK) goto DO_MARK; else if (c == UNMARK) cl_env.isp -= 2; @@ -104,7 +97,7 @@ BEGIN: } else if (c == INDENT1) { i = file_column(cl_env.print_stream)-cl_env.indent_stack[cl_env.isp]; if (i < 8 && cl_env.indent_stack[cl_env.isp] < LINE_LENGTH/2) { - writec_PRINTstream(' '); + writec_stream(' ', cl_env.print_stream); cl_env.indent_stack[cl_env.isp] = file_column(cl_env.print_stream); } else { @@ -117,8 +110,7 @@ BEGIN: } else if (c == INDENT2) { cl_env.indent_stack[cl_env.isp] = cl_env.indent_stack[cl_env.isp-1] + 2; goto PUT_INDENT; - } else if (c < 0400) - writec_PRINTstream(c); + } cl_env.qh = mod(cl_env.qh+1); --cl_env.qc; } @@ -143,9 +135,10 @@ DO_MARK: return; cl_env.qh = mod(cl_env.qh+1); --cl_env.qc; - if (++cl_env.isp >= ECL_PPRINT_INDENTATION_STACK_SIZE-1) + if (cl_env.isp >= ECL_PPRINT_INDENTATION_STACK_SIZE-2) FEerror("Can't pretty-print.", 0); - cl_env.indent_stack[cl_env.isp++] = file_column(cl_env.print_stream); + cl_env.isp+=2; + cl_env.indent_stack[cl_env.isp-1] = file_column(cl_env.print_stream); cl_env.indent_stack[cl_env.isp] = cl_env.indent_stack[cl_env.isp-1]; goto BEGIN; @@ -190,9 +183,9 @@ DO_INDENT: PUT_INDENT: cl_env.qh = mod(cl_env.qh+1); --cl_env.qc; - writec_PRINTstream('\n'); + writec_stream('\n', cl_env.print_stream); for (i = cl_env.indent_stack[cl_env.isp]; i > 0; --i) - writec_PRINTstream(' '); + writec_stream(' ', cl_env.print_stream); cl_env.iisp = cl_env.isp; goto BEGIN; @@ -200,9 +193,9 @@ FLUSH: for (j = 0; j < i; j++) { c = cl_env.queue[cl_env.qh]; if (c == INDENT || c == INDENT1 || c == INDENT2) - writec_PRINTstream(' '); + writec_stream(' ', cl_env.print_stream); else if (c < 0400) - writec_PRINTstream(c); + writec_stream(c, cl_env.print_stream); cl_env.qh = mod(cl_env.qh+1); --cl_env.qc; } @@ -446,14 +439,6 @@ call_structure_print_function(cl_object x, int level) int oisp; int oiisp; - while (interrupt_flag) { - interrupt_flag = FALSE; -#ifdef HAVE_ALARM - alarm(0); -#endif - terminal_interrupt(TRUE); - } - if (cl_env.print_pretty) flush_queue(TRUE); @@ -556,7 +541,7 @@ write_symbol(register cl_object x) } else if (x->symbol.hpack == cl_core.keyword_package) write_ch(':'); else if ((cl_env.print_package != OBJNULL && x->symbol.hpack != cl_env.print_package) - || find_symbol(x, current_package(), &intern_flag)!=x + || ecl_find_symbol(x, current_package(), &intern_flag)!=x || intern_flag == 0) { escaped = 0; for (i = 0; @@ -582,7 +567,7 @@ write_symbol(register cl_object x) } if (escaped) write_ch('|'); - if (find_symbol(x, x->symbol.hpack, &intern_flag) != x) + if (ecl_find_symbol(x, x->symbol.hpack, &intern_flag) != x) error("can't print symbol"); if ((cl_env.print_package != OBJNULL && x->symbol.hpack != cl_env.print_package) @@ -1435,7 +1420,7 @@ potential_number_p(cl_object strng, int base) cl_setup_printer(strm); cl_env.print_escape = TRUE; cl_env.print_pretty = TRUE; - writec_PRINTstream('\n'); + writec_stream('\n', cl_env.print_stream); cl_write_object(obj); flush_stream(cl_env.print_stream); @(return) diff --git a/src/c/read.d b/src/c/read.d index f7029b1a3..a3888d04b 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -160,11 +160,10 @@ SYMBOL: p = cl_core.keyword_package; else { cl_env.token->string.fillp = colon; - p = find_package(cl_env.token); - if (Null(p)) { + p = ecl_find_package_nolock(cl_env.token); + if (Null(p)) FEerror("There is no package with the name ~A.", - 1, copy_simple_string(cl_env.token)); - } + 1, copy_simple_string(cl_env.token)); } cl_env.token->string.fillp = length - (colon + 1); memmove(cl_env.token->string.self, @@ -172,15 +171,16 @@ SYMBOL: sizeof(*cl_env.token->string.self) * cl_env.token->string.fillp); if (colon > 0) { cl_env.token->string.self[cl_env.token->string.fillp] = '\0'; - x = find_symbol(cl_env.token, p, &intern_flag); - if (intern_flag != EXTERNAL) - FEerror("Cannot find the external symbol ~A in ~S.", - 2, copy_simple_string(cl_env.token), p); + x = ecl_find_symbol(cl_env.token, p, &intern_flag); + if (intern_flag != EXTERNAL) { + FEerror("Cannot find the external symbol ~A in ~S.", + 2, copy_simple_string(cl_env.token), p); + } return(x); } } else if (colon_type == 2 /* && colon > 0 && length > colon + 2 */) { cl_env.token->string.fillp = colon; - p = find_package(cl_env.token); + p = ecl_find_package_nolock(cl_env.token); if (Null(p)) { /* When loading binary files, we sometimes must create symbols whose package has not yet been maked. We @@ -207,10 +207,9 @@ SYMBOL: } else p = current_package(); cl_env.token->string.self[cl_env.token->string.fillp] = '\0'; - x = find_symbol(cl_env.token, p, &intern_flag); - if (intern_flag == 0) - x = intern(copy_simple_string(cl_env.token), p, &intern_flag); - return(x); + /* INV: make_symbol() copies the string */ + x = intern(cl_env.token, p, &intern_flag); + return x; } /* @@ -866,7 +865,7 @@ sharp_colon_reader(cl_object in, cl_object ch, cl_object d) M: if (read_suppress) @(return Cnil) - @(return make_symbol(copy_simple_string(cl_env.token))) + @(return make_symbol(cl_env.token)) } static cl_object @@ -1777,7 +1776,7 @@ init_read(void) readtable=copy_readtable(cl_core.standard_readtable, Cnil)); readtable->readtable.table['#'].dispatch_table['!'] = cl_core.default_dispatch_macro; /* We must forget #! macro. */ - ECL_SET(@'*read_default_float_format*', @'single-float'); + ECL_SET(@'*read-default-float-format*', @'single-float'); } /* diff --git a/src/c/symbol.d b/src/c/symbol.d index dd610dac2..40d2c125a 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -34,7 +34,7 @@ make_symbol(cl_object st) x = cl_alloc_object(t_symbol); /* FIXME! Should we copy? */ - x->symbol.name = st; + x->symbol.name = copy_simple_string(st); x->symbol.dynamic = 0; ECL_SET(x,OBJNULL); SYM_FUN(x) = OBJNULL; diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index ff0b5ada9..abba0dd24 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -72,7 +72,7 @@ cl_symbols[] = { {"*RANDOM-STATE*", CL_SPECIAL, NULL, -1, OBJNULL}, {"*READ-BASE*", CL_SPECIAL, NULL, -1, MAKE_FIXNUM(10)}, {"*READ-DEFAULT-FLOAT-FORMAT*", CL_SPECIAL, NULL, -1, OBJNULL}, -{"*READ-EVAL*", CL_SPECIAL, NULL, -1, OBJNULL}, +{"*READ-EVAL*", CL_SPECIAL, NULL, -1, Ct}, {"*READ-SUPPRESS*", CL_SPECIAL, NULL, -1, Cnil}, {"*READTABLE*", CL_SPECIAL, NULL, -1, OBJNULL}, {"*STANDARD-INPUT*", CL_SPECIAL, NULL, -1, OBJNULL}, @@ -1349,8 +1349,8 @@ cl_symbols[] = { #endif #ifdef ECL_THREADS -{MP_ "PROCESS", CL_ORDINARY, NULL, -1, OBJNULL}, -{MP_ "LOCK", CL_ORDINARY, NULL, -1, OBJNULL}, +{MP_ "PROCESS", MP_ORDINARY, NULL, -1, OBJNULL}, +{MP_ "LOCK", MP_ORDINARY, NULL, -1, OBJNULL}, {MP_ "*CURRENT-PROCESS*", CL_SPECIAL, NULL, -1, OBJNULL}, {MP_ "ALL-PROCESSES", MP_ORDINARY, mp_all_processes, 0, OBJNULL}, {MP_ "EXIT-PROCESS", MP_ORDINARY, mp_exit_process, 0, OBJNULL}, @@ -1362,10 +1362,15 @@ cl_symbols[] = { {MP_ "PROCESS-PRESET", MP_ORDINARY, mp_process_preset, -1, OBJNULL}, {MP_ "PROCESS-RUN-FUNCTION", MP_ORDINARY, mp_process_run_function, -1, OBJNULL}, {MP_ "PROCESS-WHOSTATE", MP_ORDINARY, mp_process_whostate, 1, OBJNULL}, -{MP_ "MAKE-LOCK", CL_ORDINARY, mp_make_lock, -1, OBJNULL}, -{MP_ "GET-LOCK", CL_ORDINARY, mp_get_lock, -1, OBJNULL}, -{MP_ "GIVEUP-LOCK", CL_ORDINARY, mp_giveup_lock, 1, OBJNULL}, +{MP_ "MAKE-LOCK", MP_ORDINARY, mp_make_lock, -1, OBJNULL}, +{MP_ "GET-LOCK", MP_ORDINARY, mp_get_lock, -1, OBJNULL}, +{MP_ "GIVEUP-LOCK", MP_ORDINARY, mp_giveup_lock, 1, OBJNULL}, {KEY_ "INITIAL-BINDINGS", KEYWORD, NULL, -1, OBJNULL}, +{MP_ "INTERRUPT-PROCESS", MP_ORDINARY, mp_interrupt_process, 2, OBJNULL}, +{MP_ "+LOAD-COMPILE-LOCK+", MP_CONSTANT, NULL, -1, OBJNULL}, +{MP_ "WITH-LOCK", MP_CONSTANT, NULL, -1, OBJNULL}, +{MP_ "WITHOUT-INTERRUPTS", MP_CONSTANT, NULL, -1, OBJNULL}, +{KEY_ "LOCKABLE", KEYWORD, NULL, -1, OBJNULL}, #endif /* Tag for end of list */ diff --git a/src/c/threads.d b/src/c/threads.d index 9561de7de..c96be7907 100644 --- a/src/c/threads.d +++ b/src/c/threads.d @@ -13,9 +13,9 @@ */ #include +#include #include "ecl.h" - -pthread_mutex_t ecl_threads_mutex = PTHREAD_MUTEX_INITIALIZER; +#include "internal.h" static pthread_key_t cl_env_key; @@ -49,21 +49,20 @@ assert_type_process(cl_object o) static void thread_cleanup(void *env) { - cl_object *p, l, process = cl_env.own_process; - - pthread_mutex_lock(&ecl_threads_mutex); - p = &cl_core.processes; - for (l = *p; l != Cnil; ) { - if (CAR(l) == process) { - *p = CDR(l); - break; - } - p = &CDR(l); - l = *p; - } - cl_dealloc(process->process.thread, sizeof(pthread_t)); - process->process.thread = NULL; - pthread_mutex_unlock(&ecl_threads_mutex); + /* This routine performs some cleanup before a thread is completely + * killed. For instance, it has to remove the associated process + * object from the list, an it has to dealloc some memory. + * + * NOTE: thread_cleanup() does not provide enough "protection". In + * order to ensure that all UNWIND-PROTECT forms are properly + * executed, never use pthread_cancel() to kill a process, but + * rather use the lisp functions mp_interrupt_process() and + * mp_process_kill(). + */ + THREAD_OP_LOCK(); + cl_core.processes = ecl_remove_eq(cl_env.own_process, + cl_core.processes); + THREAD_OP_UNLOCK(); } static void * @@ -74,14 +73,21 @@ thread_entry_point(cl_object process) pthread_setspecific(cl_env_key, process->process.env); ecl_init_env(process->process.env); - /* 2) Execute the code */ + /* 2) Execute the code. The CATCH_ALL point is the destination + * provides us with an elegant way to exit the thread: we just + * do an unwind up to frs_top. + */ + process->process.active = 1; CL_CATCH_ALL_BEGIN { bds_bind(@'mp::*current-process*', process); cl_apply(2, process->process.function, process->process.args); bds_unwind1(); } CL_CATCH_ALL_END; + process->process.active = 0; - /* 3) Remove the thread. thread_cleanup is automatically invoked. */ + /* 3) If everything went right, we should be exiting the thread + * through this point. thread_cleanup is automatically invoked. + */ pthread_cleanup_pop(1); return NULL; } @@ -92,17 +98,19 @@ thread_entry_point(cl_object process) cl_object hash; process = cl_alloc_object(t_process); + process->process.active = 0; process->process.name = name; process->process.function = Cnil; process->process.args = Cnil; - process->process.thread = NULL; + process->process.interrupt = Cnil; process->process.env = cl_alloc(sizeof(*process->process.env)); /* FIXME! Here we should either use INITIAL-BINDINGS or copy lexical * bindings */ if (initial_bindings != OBJNULL) { hash = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), make_shortfloat(1.5), - make_shortfloat(0.7)); + make_shortfloat(0.7), + Cnil); /* no need for locking */ } else { hash = si_copy_hash_table(cl_env.bindings_hash); } @@ -124,16 +132,20 @@ mp_process_preset(int narg, cl_object process, cl_object function, ...) @(return process) } +cl_object +mp_interrupt_process(cl_object process, cl_object function) +{ + if (mp_process_active_p(process) == Cnil) + FEerror("Cannot interrupt the inactive process ~A", 1, process); + process->process.interrupt = function; + pthread_kill(process->process.thread, SIGUSR1); + @(return Ct) +} + cl_object mp_process_kill(cl_object process) { - cl_object output = Cnil; - assert_type_process(process); - if (process->process.thread) { - if (pthread_cancel(*((pthread_t*)process->process.thread)) == 0) - output = Ct; - } - @(return output) + mp_interrupt_process(process, @'mp::exit-process'); } cl_object @@ -142,18 +154,15 @@ mp_process_enable(cl_object process) pthread_t *posix_thread; int code; - assert_type_process(process); - if (process->process.thread != NULL) + if (mp_process_active_p(process) != Cnil) FEerror("Cannot enable the running process ~A.", 1, process); - posix_thread = cl_alloc_atomic(sizeof(*posix_thread)); - process->process.thread = posix_thread; - pthread_mutex_lock(&ecl_threads_mutex); - code = pthread_create(posix_thread, NULL, thread_entry_point, process); + THREAD_OP_LOCK(); + code = pthread_create(&process->process.thread, NULL, thread_entry_point, process); if (!code) { /* If everything went ok, add the thread to the list. */ cl_core.processes = CONS(process, cl_core.processes); } - pthread_mutex_unlock(&ecl_threads_mutex); + THREAD_OP_UNLOCK(); @(return (code? Cnil : process)) } @@ -165,14 +174,11 @@ mp_exit_process(void) program. */ cl_quit(0); } else { - cl_object tag = cl_env.bindings_hash; - /* We simply throw with a catch value that nobody can have. This - brings up back to the thread entry point, going through all - possible UNWIND-PROTECT. + /* We simply undo the whole of the frame stack. This brings up + back to the thread entry point, going through all possible + UNWIND-PROTECT. */ - NVALUES=0; - VALUES(0)=Cnil; - cl_throw(tag); + unwind(cl_env.frs_org); } } @@ -193,7 +199,7 @@ cl_object mp_process_active_p(cl_object process) { assert_type_process(process); - @(return ((process->process.thread == NULL)? Cnil : Ct)) + @(return (process->process.active? Ct : Cnil)) } cl_object @@ -226,11 +232,14 @@ mp_process_run_function(int narg, cl_object name, cl_object function, ...) */ @(defun mp::make-lock (&key name) + pthread_mutexattr_t attr; @ + pthread_mutexattr_init(&attr); + pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE_NP); cl_object output = cl_alloc_object(t_lock); output->lock.name = name; - output->lock.mutex = cl_alloc(sizeof(pthread_mutex_t)); - pthread_mutex_init(output->lock.mutex, NULL); + pthread_mutex_init(&output->lock.mutex, &attr); + pthread_mutexattr_destroy(&attr); @(return output) @) @@ -239,7 +248,7 @@ mp_giveup_lock(cl_object lock) { if (type_of(lock) != t_lock) FEwrong_type_argument(@'mp::lock', lock); - pthread_mutex_unlock(lock->lock.mutex); + pthread_mutex_unlock(&lock->lock.mutex); @(return Ct) } @@ -249,9 +258,9 @@ mp_giveup_lock(cl_object lock) if (type_of(lock) != t_lock) FEwrong_type_argument(@'mp::lock', lock); if (wait == Ct) { - pthread_mutex_lock(lock->lock.mutex); + pthread_mutex_lock(&lock->lock.mutex); output = Ct; - } else if (pthread_mutex_trylock(lock->lock.mutex) == 0) { + } else if (pthread_mutex_trylock(&lock->lock.mutex) == 0) { output = Ct; } else { output = Cnil; @@ -264,24 +273,26 @@ init_threads() { cl_object process; struct cl_env_struct *env; + pthread_mutexattr_t attr; cl_core.processes = OBJNULL; - pthread_mutex_init(&ecl_threads_mutex, NULL); + pthread_mutexattr_init(&attr); + pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_ERRORCHECK_NP); + pthread_mutex_init(&cl_core.global_lock, &attr); + pthread_mutexattr_destroy(&attr); process = cl_alloc_object(t_process); + process->process.active = 1; process->process.name = @'si::top-level'; process->process.function = Cnil; process->process.args = Cnil; - process->process.thread = NULL; - process->process.thread = cl_alloc(sizeof(pthread_t)); - *((pthread_t *)process->process.thread) = pthread_self(); + process->process.thread = pthread_self(); process->process.env = env = cl_alloc(sizeof(*env)); pthread_key_create(&cl_env_key, NULL); pthread_setspecific(cl_env_key, env); env->own_process = process; - ECL_SET(@'mp::*current-process*', process); cl_core.processes = CONS(process, Cnil); main_thread = pthread_self(); diff --git a/src/c/unixint.d b/src/c/unixint.d index f0e8092b9..ce8ad1708 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -14,134 +14,86 @@ See file '../Copyright' for full details. */ - #include "ecl.h" #include #include - -/******************************* EXPORTS ******************************/ - -int interrupt_enable; /* console interupt enable */ -int interrupt_flag; /* console interupt flag */ +#ifdef ECL_THREADS +#include +#endif /******************************* ------- ******************************/ -typedef void (*signalfn)(int); - -#ifndef THREADS - -#ifdef SIGALRM -static void -sigalrm(void) +void +handle_signal(int sig) { - if (interrupt_flag) { - interrupt_flag = FALSE; - terminal_interrupt(TRUE); + switch (sig) { +#ifdef ECL_THREADS + case SIGUSR1: + funcall(1, cl_env.own_process->process.interrupt); + break; +#endif + case SIGINT: + funcall(2, @'si::terminal-interrupt', Ct); + break; + case SIGFPE: + FEerror("Floating-point exception.", 0); + break; + case SIGSEGV: + FEerror("Segmentation violation.", 0); + break; + default: + FEerror("Serious signal ~D caught.", 0, MAKE_FIXNUM(sig)); } } -#endif - -void -sigint(void) -{ - if (!interrupt_enable || interrupt_flag) { - if (!interrupt_enable) { - fprintf(stdout, "\n;;;Interrupt delayed.\n"); fflush(stdout); - interrupt_flag = TRUE; - } - signal(SIGINT, (signalfn)sigint); - return; - } - if (symbol_value(@'si::*interrupt-enable*') == Cnil) { - ECL_SETQ(@'si::*interrupt-enable*', Ct); - signal(SIGINT, (signalfn)sigint); - return; - } -#ifdef SIGALRM -#ifdef __GO32__ - if (interrupt_flag) - sigalrm(); -#endif - interrupt_flag = TRUE; - signal(SIGALRM, (signalfn)sigalrm); - alarm(1); -#endif - signal(SIGINT, (signalfn)sigint); -} - -#else /* THREADS */ - -extern int critical_level; -bool scheduler_interrupted = FALSE; -int scheduler_interruption = 0; - -void -sigint() -{ -#ifdef SYSV - signal(SIGINT, sigint); -#endif - if (critical_level > 0) { - scheduler_interrupted = TRUE; - scheduler_interruption = ERROR_INT; - return; - } - - if (symbol_value(@'si::*interrupt-enable*') == Cnil) { - ECL_SETQ(@'si::*interrupt-enable*', Ct); - return; - } - - terminal_interrupt(TRUE); -} - -#endif /*THREADS */ static void -sigfpe(void) +signal_catcher(int sig) { - signal(SIGFPE, (signalfn)sigfpe); - FEerror("Floating-point exception.", 0); + if (symbol_value(@'si::*interrupt-enable*') == Cnil) { + signal(sig, signal_catcher); + cl_env.interrupt_pending = sig; + return; + } + signal(sig, signal_catcher); + CL_UNWIND_PROTECT_BEGIN { + handle_signal(sig); + } CL_UNWIND_PROTECT_EXIT { + sigset_t block_mask; + sigemptyset(&block_mask); + sigaddset(&block_mask, sig); +#ifdef ECL_THREADS + pthread_sigmask(SIG_UNBLOCK, &block_mask, NULL); +#else + sigprocmask(SIG_UNBLOCK, &block_mask, NULL); +#endif + } CL_UNWIND_PROTECT_END; } -void -signal_catcher(int sig, int code, int scp) +cl_object +si_check_pending_interrupts(void) { - char str[64]; - - if (!interrupt_enable) { - sprintf(str, "signal %d caught (during GC)", sig); - error(str); - } - else if (sig == SIGSEGV) - FEerror("Segmentation violation.~%\ -Wrong type argument to a compiled function.", 0); - else { - printf("System error. Trying to recover ...\n"); - fflush(stdout); - FEerror("Signal ~D caught.~%\ -The internal memory may be broken.~%\ -You should check the signal and exit from Lisp.", 1, - MAKE_FIXNUM(sig)); - } + int what = cl_env.interrupt_pending; + cl_env.interrupt_pending = 0; + handle_signal(what); + @(return) } cl_object si_catch_bad_signals() { - signal(SIGILL, (signalfn)signal_catcher); + signal(SIGILL, signal_catcher); #ifndef GBC_BOEHM - signal(SIGBUS, (signalfn)signal_catcher); + signal(SIGBUS, signal_catcher); #endif - signal(SIGSEGV, (signalfn)signal_catcher); + signal(SIGSEGV, signal_catcher); #ifdef SIGIOT - signal(SIGIOT, (signalfn)signal_catcher); + signal(SIGIOT, signal_catcher); #endif #ifdef SIGEMT - signal(SIGEMT, (signalfn)signal_catcher); + signal(SIGEMT, signal_catcher); #endif #ifdef SIGSYS - signal(SIGSYS, (signalfn)signal_catcher); + signal(SIGSYS, signal_catcher); #endif @(return Ct) } @@ -167,12 +119,12 @@ si_uncatch_bad_signals() } void -enable_interrupt(void) +init_unixint(void) { - interrupt_enable = TRUE; - signal(SIGFPE, (signalfn)sigfpe); - signal(SIGINT, (signalfn)sigint); -#ifdef __EMX__ - signal(SIGBREAK, (signalfn)sigint); + signal(SIGFPE, signal_catcher); + signal(SIGINT, signal_catcher); +#ifdef ECL_THREADS + signal(SIGUSR1, signal_catcher); #endif + ECL_SET(@'si::*interrupt-enable*', Ct); } diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 826b001ca..9ea9026f8 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -10,6 +10,8 @@ ;;;; CMPDEF Definitions +(si::package-lock "CL" nil) + (defpackage "C" (:nicknames "COMPILER") (:use "FFI" "CL") diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 8c8d00f1f..9560279d7 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -350,37 +350,39 @@ Cannot compile ~a." (shared-data-pathname (get-output-pathname o-pathname shared-data-file :sdata))) - (init-env) + (mp:with-lock (mp:+load-compile-lock+) + (init-env) - (when (probe-file "./cmpinit.lsp") - (load "./cmpinit.lsp" :verbose *compile-verbose*)) + (when (probe-file "./cmpinit.lsp") + (load "./cmpinit.lsp" :verbose *compile-verbose*)) - (if shared-data-file - (if system-p - (data-init shared-data-pathname) - (error "Shared data files are only allowed when compiling ~& + (if shared-data-file + (if system-p + (data-init shared-data-pathname) + (error "Shared data files are only allowed when compiling ~& with the flag :SYSTEM-P set to T.")) - (data-init)) + (data-init)) - (with-open-file (*compiler-input* *compile-file-pathname*) - (do ((form (read *compiler-input* nil eof) - (read *compiler-input* nil eof))) - ((eq form eof)) - (t1expr form))) + (with-open-file (*compiler-input* *compile-file-pathname*) + (do ((form (read *compiler-input* nil eof) + (read *compiler-input* nil eof))) + ((eq form eof)) + (t1expr form))) - (when (zerop *error-count*) - (when *compile-verbose* (format t "~&;;; End of Pass 1. ")) - (compiler-pass2 c-pathname h-pathname data-pathname system-p - (if system-p - (pathname-name input-pathname) - "code") - shared-data-file)) + (when (zerop *error-count*) + (when *compile-verbose* (format t "~&;;; End of Pass 1. ")) + (compiler-pass2 c-pathname h-pathname data-pathname system-p + (if system-p + (pathname-name input-pathname) + "code") + shared-data-file)) - (if shared-data-file - (data-dump shared-data-pathname t) - (data-dump data-pathname)) + (if shared-data-file + (data-dump shared-data-pathname t) + (data-dump data-pathname)) - (init-env) + (init-env) + ) (if (zerop *error-count*) (progn @@ -430,7 +432,8 @@ Cannot compile ~a." (setq *error-p* t) (values nil t t)) )) - ) + ) ; mp:with-lock +) #-dlopen (defun compile (name &optional (def nil supplied-p)) @@ -491,19 +494,16 @@ Cannot compile ~a." (o-pathname (compile-file-pathname data-pathname :type :object)) (so-pathname (compile-file-pathname data-pathname))) - (init-env) - - (data-init) - - (t1expr form) - - (when (zerop *error-count*) - (when *compile-verbose* (format t "~&;;; End of Pass 1. ")) - (compiler-pass2 c-pathname h-pathname data-pathname nil "code" nil)) - - (data-dump data-pathname) - - (init-env) + (mp:with-lock (mp:+load-compile-lock+) + (init-env) + (data-init) + (t1expr form) + (when (zerop *error-count*) + (when *compile-verbose* (format t "~&;;; End of Pass 1. ")) + (compiler-pass2 c-pathname h-pathname data-pathname nil "code" nil)) + (data-dump data-pathname) + (init-env) + ) (if (zerop *error-count*) (progn @@ -571,30 +571,32 @@ Cannot compile ~a." (*error-count* 0) (t3local-fun (symbol-function 'T3LOCAL-FUN)) (t3fun (get-sysprop 'DEFUN 'T3))) - (unwind-protect - (progn - (put-sysprop 'DEFUN 'T3 - #'(lambda (&rest args) - (let ((*compiler-output1* *standard-output*)) - (apply t3fun args)))) - (setf (symbol-function 'T3LOCAL-FUN) - #'(lambda (&rest args) - (let ((*compiler-output1* *standard-output*)) - (apply t3local-fun args)))) - (init-env) - (data-init) - (t1expr disassembled-form) - (if (zerop *error-count*) - (catch *cmperr-tag* (ctop-write "code" - (if h-file (namestring h-file) "") - (if data-file (namestring data-file) "") - :system-p nil)) - (setq *error-p* t)) - (data-dump data-file) - ) - (put-sysprop 'DEFUN 'T3 t3fun) - (setf (symbol-function 'T3LOCAL-FUN) t3local-fun) - (when h-file (close *compiler-output2*)))) + (mp:with-lock (mp:+load-compile-lock+) + (unwind-protect + (progn + (put-sysprop 'DEFUN 'T3 + #'(lambda (&rest args) + (let ((*compiler-output1* *standard-output*)) + (apply t3fun args)))) + (setf (symbol-function 'T3LOCAL-FUN) + #'(lambda (&rest args) + (let ((*compiler-output1* *standard-output*)) + (apply t3local-fun args)))) + (init-env) + (data-init) + (t1expr disassembled-form) + (if (zerop *error-count*) + (catch *cmperr-tag* (ctop-write "code" + (if h-file (namestring h-file) "") + (if data-file (namestring data-file) "") + :system-p nil)) + (setq *error-p* t)) + (data-dump data-file) + (init-env) + ) + (put-sysprop 'DEFUN 'T3 t3fun) + (setf (symbol-function 'T3LOCAL-FUN) t3local-fun) + (when h-file (close *compiler-output2*))))) (values) ) @@ -652,5 +654,7 @@ Cannot compile ~a." (defmacro with-compilation-unit (options &rest body) `(progn ,@body)) +(si::package-lock "CL" nil) + ;;; ---------------------------------------------------------------------- (provide "compiler") diff --git a/src/h/ecl-cmp.h b/src/h/ecl-cmp.h index e788e1db0..6536a48c1 100644 --- a/src/h/ecl-cmp.h +++ b/src/h/ecl-cmp.h @@ -25,8 +25,10 @@ #include "gmp.h" #include "object.h" #include "stacks.h" -#ifdef THREADS -# include "lwp.h" +#ifdef ECL_THREADS +# include +# define start_critical_section() +# define end_critical_section() #else # define start_critical_section() # define end_critical_section() diff --git a/src/h/ecl.h b/src/h/ecl.h index fcf999a87..db19c6c5e 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -26,8 +26,10 @@ #include "gmp.h" #include "object.h" #include "stacks.h" -#ifdef THREADS -# include "lwp.h" +#ifdef ECL_THREADS +# include +# define start_critical_section() +# define end_critical_section() #else # define start_critical_section() # define end_critical_section() diff --git a/src/h/external.h b/src/h/external.h index 92f50ab89..bdb76caeb 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -112,6 +112,7 @@ struct cl_env_struct { #ifdef ECL_THREADS cl_object own_process; #endif + int interrupt_pending; }; #ifdef ECL_THREADS @@ -176,6 +177,7 @@ struct cl_core_struct { #ifdef ECL_THREADS cl_object processes; + pthread_mutex_t global_lock; #endif }; @@ -434,7 +436,6 @@ extern cl_object cl_cerror _ARGS((int narg, cl_object cformat, cl_object eformat extern void internal_error(const char *s) __attribute__((noreturn)); extern void cs_overflow(void) __attribute__((noreturn)); extern void error(const char *s) __attribute__((noreturn)); -extern void terminal_interrupt(bool correctable); extern void FEprogram_error(const char *s, int narg, ...) __attribute__((noreturn)); extern void FEcontrol_error(const char *s, int narg, ...) __attribute__((noreturn)); extern void FEreader_error(const char *s, cl_object stream, int narg, ...) __attribute__((noreturn)); @@ -582,7 +583,7 @@ extern cl_object compute_method(int narg, cl_object fun, cl_object *args); /* hash.c */ -extern cl_object cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, cl_object rehash_threshold); +extern cl_object cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, cl_object rehash_threshold, cl_object lockable); extern cl_object cl_hash_table_p(cl_object ht); extern cl_object si_hash_set(cl_object key, cl_object ht, cl_object val); extern cl_object cl_remhash(cl_object key, cl_object ht); @@ -603,7 +604,6 @@ extern cl_hashkey hash_eq(cl_object x); extern cl_hashkey hash_eql(cl_object x); extern cl_hashkey hash_equal(cl_object x); extern void sethash(cl_object key, cl_object hashtable, cl_object value); -extern void extend_hashtable(cl_object hashtable); extern cl_object gethash(cl_object key, cl_object hash); extern cl_object gethash_safe(cl_object key, cl_object hash, cl_object def); extern bool remhash(cl_object key, cl_object hash); @@ -727,6 +727,8 @@ extern cl_object assq(cl_object x, cl_object l); extern cl_object assql(cl_object x, cl_object l); extern cl_object assoc(cl_object x, cl_object l); extern cl_object assqlp(cl_object x, cl_object l); +extern cl_object ecl_remove_eq(cl_object x, cl_object l); +extern void ecl_delete_eq(cl_object x, cl_object *l); /* load.c */ @@ -956,12 +958,12 @@ extern cl_object cl_unuse_package _ARGS((int narg, cl_object pack, ...)); extern cl_object make_package(cl_object n, cl_object ns, cl_object ul); extern cl_object rename_package(cl_object x, cl_object n, cl_object ns); -extern cl_object find_package(cl_object n); +extern cl_object ecl_find_package_nolock(cl_object n); extern cl_object si_coerce_to_package(cl_object p); extern cl_object current_package(void); +extern cl_object ecl_find_symbol(cl_object n, cl_object p, int *intern_flag); extern cl_object intern(cl_object name, cl_object p, int *intern_flag); extern cl_object _intern(const char *s, cl_object p); -extern cl_object find_symbol(cl_object name, cl_object p, int *intern_flag); extern bool unintern(cl_object s, cl_object p); extern void cl_export2(cl_object s, cl_object p); extern void cl_unexport2(cl_object s, cl_object p); @@ -1325,6 +1327,7 @@ extern cl_object make_stream(cl_object host, int fd, enum ecl_smmode smm); extern cl_object mp_own_process(void) __attribute__((const)); extern cl_object mp_all_processes(void); extern cl_object mp_exit_process(void) __attribute__((noreturn)); +extern cl_object mp_interrupt_process(cl_object process, cl_object function); extern cl_object mp_make_process _ARGS((int narg, ...)); extern cl_object mp_process_active_p(cl_object process); extern cl_object mp_process_enable(cl_object process); @@ -1420,10 +1423,7 @@ extern cl_object homedir_pathname(cl_object user); extern cl_object si_catch_bad_signals(); extern cl_object si_uncatch_bad_signals(); -extern int interrupt_enable; -extern int interrupt_flag; -extern void signal_catcher(int sig, int code, int scp); -extern void enable_interrupt(void); +extern cl_object si_check_pending_interrupts(); /* unixsys.c */ diff --git a/src/h/internal.h b/src/h/internal.h index 5d001956a..3aab9a382 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -28,8 +28,6 @@ extern void init_big(void); #ifdef CLOS extern void init_clos(void); #endif -extern void init_cmpaux(void); -extern void init_compiler(void); extern void init_error(void); extern void init_eval(void); extern void init_file(void); @@ -40,6 +38,7 @@ extern void init_macros(void); extern void init_number(void); extern void init_read(void); extern void init_stacks(int *); +extern void init_unixint(void); extern void init_unixtime(void); @@ -79,6 +78,9 @@ extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size); #define OPEN_A "ab" #define OPEN_RA "a+b" +/* hash.d */ +extern void ecl_extend_hashtable(cl_object hashtable); + /* num_log.d */ #define BOOLCLR 0 @@ -113,6 +115,10 @@ cl_object ecl_library_error(cl_object block); void ecl_library_close(cl_object block); #endif +/* package.d */ + +extern cl_object ecl_find_symbol_nolock(cl_object name, cl_object p, int *intern_flag); + /* print.d */ #define ECL_PPRINT_QUEUE_SIZE 128 @@ -122,7 +128,39 @@ extern void edit_double(int n, double d, int *sp, char *s, int *ep); extern void cl_setup_printer(cl_object strm); extern void cl_write_object(cl_object x); - /* read.d */ +/* global locks */ + +#ifdef ECL_THREADS +#if 0 +#define HASH_TABLE_LOCK(h) if ((h)->hash.lockable) pthread_mutex_lock(&(h)->hash.lock) +#define HASH_TABLE_UNLOCK(h) if ((h)->hash.lockable) pthread_mutex_unlock(&(h)->hash.lock) +#define PACKAGE_LOCK(p) pthread_mutex_lock(&(p)->pack.lock) +#define PACKAGE_UNLOCK(p) pthread_mutex_unlock(&(p)->pack.lock) +#define PACKAGE_OP_LOCK() pthread_mutex_lock(&cl_core.global_lock) +#define PACKAGE_OP_UNLOCK() pthread_mutex_unlock(&cl_core.global_lock) +#define THREAD_OP_LOCK() pthread_mutex_lock(&cl_core.global_lock) +#define THREAD_OP_UNLOCK() pthread_mutex_unlock(&cl_core.global_lock) +#else +#define HASH_TABLE_LOCK(h) if ((h)->hash.lockable) if (pthread_mutex_lock(&(h)->hash.lock)) internal_error("") +#define PACKAGE_LOCK(p) if (pthread_mutex_lock(&(p)->pack.lock)) internal_error("") +#define PACKAGE_OP_LOCK() if (pthread_mutex_lock(&cl_core.global_lock)) internal_error("") +#define THREAD_OP_LOCK() if (pthread_mutex_lock(&cl_core.global_lock)) internal_error("") +#define HASH_TABLE_UNLOCK(h) if ((h)->hash.lockable) if (pthread_mutex_unlock(&(h)->hash.lock)) internal_error("") +#define PACKAGE_UNLOCK(p) if (pthread_mutex_unlock(&(p)->pack.lock)) internal_error("") +#define PACKAGE_OP_UNLOCK() if (pthread_mutex_unlock(&cl_core.global_lock)) internal_error("") +#define THREAD_OP_UNLOCK() if (pthread_mutex_unlock(&cl_core.global_lock)) internal_error("") +#endif +#else +#define HASH_TABLE_LOCK(h) +#define HASH_TABLE_UNLOCK(h) +#define PACKAGE_LOCK(p) +#define PACKAGE_UNLOCK(p) +#define PACKAGE_OP_LOCK() +#define PACKAGE_OP_UNLOCK() +#endif + + +/* read.d */ #define RTABSIZE CHAR_CODE_LIMIT /* read table size */ #ifdef __cplusplus diff --git a/src/h/object.h b/src/h/object.h index 1ea178abe..b4d11d3c3 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -144,6 +144,9 @@ struct ecl_package { cl_object usedby; /* used-by-list of packages */ cl_object internal; /* hashtable for internal symbols */ cl_object external; /* hashtable for external symbols */ +#ifdef ECL_THREADS + pthread_mutex_t lock; /* thread safe packages */ +#endif }; /* @@ -178,12 +181,15 @@ struct ecl_hashtable_entry { /* hash table entry */ }; struct ecl_hashtable { /* hash table header */ - HEADER1(test); + HEADER2(test,lockable); struct ecl_hashtable_entry *data; /* pointer to the hash table */ cl_object rehash_size; /* rehash size */ cl_object threshold; /* rehash threshold */ cl_index entries; /* number of entries */ cl_index size; /* hash table size */ +#ifdef ECL_THREADS + pthread_mutex_t lock; /* mutex to prevent race conditions */ +#endif }; typedef enum { /* array element type */ @@ -401,11 +407,11 @@ struct ecl_dummy { #ifdef ECL_THREADS struct ecl_process { - HEADER; + HEADER1(active); cl_object name; cl_object function; cl_object args; - void *thread; + pthread_t thread; struct cl_env_struct *env; cl_object interrupt; }; @@ -413,7 +419,7 @@ struct ecl_process { struct ecl_lock { HEADER; cl_object name; - void *mutex; + pthread_mutex_t mutex; }; #endif diff --git a/src/lsp/load.lsp.in b/src/lsp/load.lsp.in index 05b24af31..97b960811 100644 --- a/src/lsp/load.lsp.in +++ b/src/lsp/load.lsp.in @@ -35,12 +35,12 @@ "@abs_srcdir@/ffi.lsp" #+ffi "@abs_srcdir@/ffi-objects.lsp" -; #+threads -; "@abs_srcdir@/thread.lsp" #+tk "@abs_srcdir@/tk-init.lsp" "@abs_builddir@/config.lsp" - "@abs_srcdir@/top.lsp")) + "@abs_srcdir@/top.lsp" + "@abs_srcdir@/mp.lsp" +)) (mapc #'(lambda (x) (load x :verbose nil)) (cddddr +lisp-module-files+))