From ef8fbc903defb32934eebd93b3301fa67fd8501d Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 8 Oct 2005 14:46:09 +0000 Subject: [PATCH] Fixes for the old garbage collector --- src/CHANGELOG | 4 ++++ src/c/alloc.d | 18 +++++++++++---- src/c/cinit.d | 6 +++++ src/c/compiler.d | 12 +++------- src/c/ffi.d | 39 ++++++++++++++++----------------- src/c/gbc.d | 51 ++++++++++++++++++++++++++++++++++--------- src/c/load.d | 17 +-------------- src/c/main.d | 2 ++ src/c/symbols_list2.h | 2 +- src/cmp/cmpffi.lsp | 18 +++++++++++++++ src/h/external.h | 1 + src/h/internal.h | 11 ++++++++++ src/lsp/ffi.lsp | 4 ++-- 13 files changed, 123 insertions(+), 62 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 88d21db31..55aa402fd 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -33,6 +33,10 @@ ECL 0.9h true bignums then, just long long int if possible; doesn't work with native compilation because compiler needs true bignums). +* System design: + + - ECL's own conservative garbage collector works again. + * Visible changes: - The code for handling command line options has been redesigned. Now multiple diff --git a/src/c/alloc.d b/src/c/alloc.d index ee5a3a7e5..4e3b4cb26 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -271,6 +271,7 @@ ONCE_MORE: obj->symbol.gfdef = OBJNULL; obj->symbol.value = OBJNULL; obj->symbol.name = OBJNULL; + obj->symbol.hpack = OBJNULL; break; case t_package: obj->pack.name = OBJNULL; @@ -291,6 +292,7 @@ ONCE_MORE: obj->hash.data = NULL; break; case t_array: + obj->array.dims = NULL; obj->array.displaced = Cnil; obj->array.elttype = (short)aet_object; obj->array.self.t = NULL; @@ -358,8 +360,11 @@ ONCE_MORE: */ #ifdef ECL_THREADS case t_process: - obj->process.env = OBJNULL; - obj->process.thread = OBJNULL; + obj->process.name = OBJNULL; + obj->process.function = OBJNULL; + obj->process.args = OBJNULL; + obj->process.env = NULL; + obj->process.interrupt = OBJNULL; break; case t_lock: obj->lock.mutex = OBJNULL; @@ -367,7 +372,9 @@ ONCE_MORE: #endif #ifdef CLOS case t_instance: + obj->instance.length = 0; CLASS_OF(obj) = OBJNULL; + obj->instance.sig = Cnil; obj->instance.isgf = 0; obj->instance.slots = NULL; break; @@ -582,7 +589,10 @@ cl_alloc_align(cl_index size, cl_index align) void *output; start_critical_section(); align--; - output = (void*)(((cl_index)cl_alloc(size + align) + align - 1) & ~align) + if (align) + output = (void*)(((cl_index)cl_alloc(size + align) + align - 1) & ~align); + else + output = cl_alloc(size); end_critical_section(); return output; } @@ -698,7 +708,7 @@ init_alloc(void) init_tm(t_foreign, "LFOREIGN", sizeof(struct ecl_foreign), 1); #ifdef ECL_THREADS init_tm(t_process, "tPROCESS", sizeof(struct ecl_process), 2); - init_tm(t_process, "tLOCK", sizeof(struct ecl_lock), 2); + init_tm(t_lock, "tLOCK", sizeof(struct ecl_lock), 2); #endif /* THREADS */ ncb = 0; diff --git a/src/c/cinit.d b/src/c/cinit.d index e1b2fa7bc..23c41a7b4 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -22,6 +22,12 @@ cl_array_dimensions(cl_narg narg, cl_object array, ...) return funcall(2, @'ARRAY-DIMENSIONS', array); } +extern cl_object +cl_vector_push(cl_object elt, cl_object vector) +{ + return funcall(2, @'VECTOR-PUSH', vector, elt); +} + static cl_object si_simple_toplevel () { cl_object sentence; diff --git a/src/c/compiler.d b/src/c/compiler.d index 96f7479c2..e4df7a143 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -49,15 +49,6 @@ #define FLAG_IGNORE 0 #define FLAG_USEFUL (FLAG_PUSH | FLAG_VALUES | FLAG_REG0) -struct cl_compiler_env { - cl_object variables; - cl_object macros; - cl_fixnum lexical_level; - cl_object constants; - bool coalesce; - bool stepping; -}; - #define ENV cl_env.c_env /********************* PRIVATE ********************/ @@ -2097,6 +2088,8 @@ compile_body(cl_object body, int flags) { @(return declarations body documentation specials) @) +static size_t si_process_lambda_ctr = 0; + cl_object si_process_lambda(cl_object lambda) { @@ -2112,6 +2105,7 @@ si_process_lambda(cl_object lambda) documentation = VALUES(2); specials = VALUES(3); + si_process_lambda_ctr++; VALUES(0) = si_process_lambda_list(lambda_list, @'function'); VALUES(NVALUES++) = documentation; diff --git a/src/c/ffi.d b/src/c/ffi.d index 2694129f5..59f1f95cc 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -47,26 +47,24 @@ char * ecl_string_pointer_safe(cl_object f) { cl_index l; - - if (type_of(f) != t_string) - FEwrong_type_argument(@'string', f); -#ifdef GBC_BOEHM - /* This function is only used in CMPFFI.LSP as to convert lisp objects - * to a null terminated string. This code is safe with the - * Boehm-Weiser garbage collector because the pointer is stored in the - * stack as part of the argument list and cannot be lost. We still have to - * figure out what to do with the older garbage collector. - */ - if (f->string.hasfillp && ((l = f->string.fillp) < f->string.dim)) { - unsigned char *s = cl_alloc_atomic(l + 1); - memcpy(s, f->string.self, l); - s[l] = 0; - return s; + unsigned char *s; + assert_type_string(f); + s = f->string.self; + if (f->string.hasfillp && s[f->string.fillp] != 0) { + FEerror("Cannot coerce a string with fill pointer to (char *)", 0); + } + return (char *)s; +} + +cl_object +ecl_null_terminated_string(cl_object f) +{ + assert_type_string(f); + if (f->string.hasfillp && f->string.self[f->string.fillp] != 0) { + return cl_copy_seq(f); + } else { + return f; } -#else -# error "ecl_string_pointer_safe does not work with the old garbage collector" -#endif - return f->string.self; } cl_object @@ -407,7 +405,8 @@ si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_objec void *sym; block = (module == @':default' ? module : si_load_foreign_module(module)); - sym = ecl_library_symbol(block, ecl_string_pointer_safe(var)); + var = ecl_null_terminated_string(var); + sym = ecl_library_symbol(block, var->string.self); if (sym == NULL) { if (block != @':default') output = ecl_library_error(block); diff --git a/src/c/gbc.d b/src/c/gbc.d index ce166c895..0b28f3657 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -162,8 +162,8 @@ BEGIN: mark_object(x->symbol.hpack); mark_object(x->symbol.name); mark_object(x->symbol.plist); - mark_object(SYM_FUN(x)); - mark_next(SYM_VAL(x)); + mark_object(x->symbol.gfdef); + mark_next(x->symbol.value); break; case t_package: @@ -350,6 +350,7 @@ BEGIN: case t_process: /* Already marked by malloc: x->process.env */ + mark_object(x->process.name); mark_object(x->process.interrupt); mark_object(x->process.function); mark_cl_env(x->process.env); @@ -361,7 +362,8 @@ BEGIN: #endif /* THREADS */ #ifdef CLOS case t_instance: - mark_object(CLASS_OF(x)); + mark_object(x->instance.clas); + mark_object(x->instance.sig); p = x->instance.slots; i = x->instance.length; goto MARK_DATA; @@ -432,7 +434,8 @@ mark_cl_env(struct cl_env_struct *env) int i; cl_object where; bds_ptr bdp; - frame_ptr frp; + ecl_frame_ptr frp; + struct ihs_frame *ihs; mark_contblock(env, sizeof(*env)); @@ -441,29 +444,37 @@ mark_cl_env(struct cl_env_struct *env) mark_contblock(env->stack, env->stack_size * sizeof(cl_object)); mark_stack_conservative((cl_ptr)env->stack, (cl_ptr)env->stack_top); - if (bdp = env->bds_org) { + if ((bdp = env->bds_org)) { mark_contblock(bdp, env->bds_size * sizeof(*bdp)); for (; bdp <= env->bds_top; bdp++) { mark_object(bdp->symbol); mark_object(bdp->value); } } + mark_object(env->bindings_hash); - if (frp = env->frs_org) { + if ((frp = env->frs_org)) { mark_contblock(frp, env->frs_size * sizeof(*frp)); for (; frp <= env->frs_top; frp++) { mark_object(frp->frs_val); } } + for (ihs = env->ihs_top; ihs; ihs = ihs->next) { + mark_object(ihs->function); + mark_object(ihs->lex_env); + } + for (i=0; invalues; i++) mark_object(env->values[i]); mark_object(env->token); -/* mark_object(env->c_env->variables); - mark_object(env->c_env->macros); - mark_object(env->c_env->constants); */ + if (env->c_env) { + mark_object(env->c_env->variables); + mark_object(env->c_env->macros); + mark_object(env->c_env->constants); + } mark_object(env->fmt_aux_stream); @@ -491,6 +502,10 @@ mark_phase(void) { int i; + /* save registers on the stack */ + jmp_buf volatile registers; + ecl_setjmp(registers); + /* mark registered symbols & keywords */ for (i=0; ivector.elttype = aet_fix; mark_stack_conservative((cl_ptr)&cl_core.packages, - (cl_ptr)(&cl_core.system_properties + 1)); + (cl_ptr)(&cl_core.libraries + 1)); + cl_core.libraries->vector.elttype = aet_object; /* mark roots */ for (i = 0; i < gc_roots; i++) @@ -571,12 +591,23 @@ sweep_phase(void) break; #endif case t_stream: +#if defined(ECL_WSOCK) + if (x->stream.mode == smm_input_wsock + || x->stream.mode == smm_output_wsock + || x->stream.mode == smm_io_wsock) { + closesocket((int)x->stream.file); + } else +#endif if (x->stream.file != NULL) fclose(x->stream.file); x->stream.file = NULL; #ifdef ECL_THREADS case t_lock: +#if defined(_MSC_VER) || defined(mingw32) + CloseHandle(x->lock.mutex); +#else pthread_mutex_destroy(&x->lock.mutex); +#endif break; #endif default:; diff --git a/src/c/load.d b/src/c/load.d index 9dc832223..b054ecf6b 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -73,22 +73,7 @@ ecl_library_open(cl_object filename) { /* INV: We can modify "libraries" in a multithread environment because we have already taken the +load-compile-lock+ */ - if (libraries->vector.fillp == libraries->vector.dim) { - cl_object nvector = cl_alloc_object(t_vector); - nvector->vector = libraries->vector; - if (libraries->vector.dim == 0) - libraries->vector.dim = 16; - else - libraries->vector.dim *= 2; - libraries->vector.self.t = - cl_alloc_atomic(libraries->vector.dim * - sizeof(cl_object)); - memcpy(libraries->vector.self.t, - nvector->vector.self.t, - nvector->vector.fillp * sizeof(cl_object)); - } - libraries->vector.self.t[libraries->vector.fillp++] - = block; + cl_vector_push(block, libraries); return block; } diff --git a/src/c/main.d b/src/c/main.d index 00bf626a9..30d345e29 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -52,6 +52,8 @@ ecl_init_env(struct cl_env_struct *env) env->lex_env = Cnil; + env->c_env = NULL; + env->token = cl_alloc_adjustable_string(LISP_PAGESIZE); env->stack = NULL; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 70b8f5a07..73d9bb035 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1440,7 +1440,7 @@ cl_symbols[] = { {SYS_ "FOREIGN-DATA-SET-ELT","si_foreign_data_set_elt"}, {SYS_ "FOREIGN-DATA-TAG","si_foreign_data_tag"}, {SYS_ "FREE-FOREIGN-DATA","si_free_foreign_data"}, -{SYS_ "LOAD-FOREIGN-MODULE", "si_load_foreign_module"}, +{SYS_ "LOAD-FOREIGN-MODULE","si_load_foreign_module"}, {SYS_ "NULL-POINTER-P","si_null_pointer_p"}, {SYS_ "SIZE-OF-FOREIGN-ELT-TYPE","si_size_of_foreign_elt_type"}, {KEY_ "BYTE",NULL}, diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 1e5981218..49ecf90db 100644 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -37,6 +37,7 @@ :void (nil "void") :pointer-void (foreign-data "void*") :cstring (string "char*") + :char* (string "char*") :short ((integer #.si:c-short-min #.si:c-short-max) "short") :unsigned-short ((integer 0 #.si:c-short-max) "unsigned short") )) @@ -223,6 +224,8 @@ (otherwise (coercion-error)))) ((:cstring) + (coercion error)) + ((:char*) (case loc-rep-type ((:object) (wt "ecl_string_pointer_safe(" loc ")")) @@ -241,12 +244,27 @@ (defun c1c-inline (args) ;; We are on the safe side by assuming that the form has side effects (destructuring-bind (arguments arg-types output-type c-expression + &rest rest &key (side-effects t) one-liner &aux output-rep-type) args (unless (= (length arguments) (length arg-types)) (cmperr "In a C-INLINE form the number of declare arguments and the number of supplied ones do not match:~%~S" `(C-INLINE ,@args))) + ;; We cannot handle :cstrings as input arguments. :cstrings are + ;; null-terminated strings, but not all of our lisp strings will + ;; be null terminated. In particular, those with a fill pointer + ;; will not. + (let ((ndx (position :cstring arguments))) + (when ndx + (let* ((var (gensym)) + (value (elt ndx arguments))) + (setf (elt ndx arguments) var + (elt ndx arg-types) :char*) + (return-from c1c-inline + `(with-ctring (,var ,value) + (c1c-inline ,arguments ,arg-types ,output-type ,c-expression + ,@rest)))))) ;; Find out the output types of the inline form. The syntax is rather relax ;; output-type = lisp-type | c-type | (values {lisp-type | c-type}*) (flet ((produce-type-pair (type) diff --git a/src/h/external.h b/src/h/external.h index 6742c42e6..8de946129 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -510,6 +510,7 @@ extern cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data) extern cl_object ecl_allocate_foreign_data(cl_object tag, cl_index size); extern void *ecl_foreign_data_pointer_safe(cl_object f); extern char *ecl_string_pointer_safe(cl_object f); +extern cl_object ecl_null_terminated_string(cl_object s); /* file.c */ diff --git a/src/h/internal.h b/src/h/internal.h index 8f7a6ad14..29e49ea42 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -52,6 +52,17 @@ extern void init_CLOS(cl_object); extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size); +/* compiler.d */ + +struct cl_compiler_env { + cl_object variables; + cl_object macros; + cl_fixnum lexical_level; + cl_object constants; + bool coalesce; + bool stepping; +}; + /* interpreter.d */ #define cl_stack_ref(n) cl_env.stack[n] diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index a918a3552..57474a678 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -26,8 +26,8 @@ "CONVERT-FROM-FOREIGN-STRING" "ALLOCATE-FOREIGN-STRING" "WITH-FOREIGN-STRING" "WITH-FOREIGN-STRINGS" "FOREIGN-STRING-LENGTH" "WITH-FOREIGN-OBJECT" - "FIND-FOREIGN-LIBRARY" "LOAD-FOREIGN-LIBRARY" "WITH-FOREIGN-STRING" - "WITH-FOREIGN-STRINGS" "ENSURE-CHAR-STORABLE" "DEF-TYPE" + "FIND-FOREIGN-LIBRARY" "LOAD-FOREIGN-LIBRARY" + "ENSURE-CHAR-STORABLE" "DEF-TYPE" "WITH-CSTRING" "CONVERT-TO-CSTRING" "CONVERT-FROM-CSTRING" "FREE-CSTRING" "WITH-CAST-POINTER" "WITH-CSTRINGS" )