Fixes for the old garbage collector

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

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;

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;

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;

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

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; i<env->nvalues; 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; i<cl_num_symbols_in_core; i++) {
 		cl_object s = (cl_object)(cl_symbols + i);
@@ -501,8 +516,13 @@ mark_phase(void)
 		mark_object(s);
 	}
 
+	/* We mark everything, but we do not want to get the loaded
+	 * libraries to be marked unless they are referenced somewhere
+	 * else (function definition. etc) */
+	cl_core.libraries->vector.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:;

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

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;

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},

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)

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

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]

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