Implementation of dynamically created callbacks. FASL files and DLLs are now garbage collected unless a symbol has been referenced with si::find-foreign-symbol.

src/c/alloc.d

@@ -380,6 +380,7 @@ ONCE_MORE:
 	  break;
 #endif /* CLOS */
 	case t_codeblock:
+	  obj->cblock.locked = 0;
 	  obj->cblock.name = Cnil;
 	  obj->cblock.handle = NULL;
 	  obj->cblock.entry = NULL;

src/c/alloc_2.d

@@ -112,6 +112,7 @@ cl_alloc_object(cl_type t)
 	switch (t) {
 #ifdef ENABLE_DLOPEN
 	case t_codeblock:
+		obj->cblock.locked = 0;
 		obj->cblock.links = Cnil;
 		obj->cblock.name = Cnil;
 		obj->cblock.next = Cnil;
@@ -282,8 +283,23 @@ ecl_mark_env(struct cl_env_struct *env)
 static void
 stacks_scanner()
 {
+	cl_object l;
+	l = cl_core.libraries;
+	if (l) {
+		int i;
+		for (i = 0; i < l->vector.fillp; i++) {
+			cl_object dll = l->vector.self.t[i];
+			if (dll->cblock.locked) {
+				GC_push_conditional((ptr_t)dll, (ptr_t)(&dll->cblock + 1), 1);
+				GC_set_mark_bit(dll);
+			}
+		}
+		GC_set_mark_bit(l->vector.self.t);
+	}
+	GC_push_all((ptr_t)(&cl_core), (ptr_t)(&cl_core + 1));
+	GC_push_all((ptr_t)cl_symbols, (ptr_t)(cl_symbols + cl_num_symbols_in_core));
 #ifdef ECL_THREADS
-	cl_object l = cl_core.processes;
+	l = cl_core.processes;
 	struct cl_env_struct cl_env_ptr;
 	if (l == OBJNULL) {
 		ecl_mark_env(&cl_env);
@@ -297,8 +313,6 @@ stacks_scanner()
 #else
 	ecl_mark_env(&cl_env);
 #endif
-	GC_push_all((ptr_t)&cl_core, (ptr_t)(&cl_core + 1));
-	GC_push_all((ptr_t)cl_symbols, (ptr_t)(cl_symbols + cl_num_symbols_in_core));
 	if (old_GC_push_other_roots)
 		(*old_GC_push_other_roots)();
 }

src/c/arch/ffi_x86.d

@@ -13,6 +13,7 @@
 */
 
 #include <ecl.h>
+#include <string.h>
 #include <internal.h>
 
 void
@@ -96,3 +97,115 @@ ecl_fficall_execute(void *f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag r
 	sp += fficall->buffer_size;
 #endif
 }
+
+static void
+ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer)
+{
+	cl_object fun, rtype, argtypes;
+	cl_object result;
+	cl_index i, size;
+	union ecl_ffi_values output;
+	enum ecl_ffi_tag tag;
+
+	fun = CAR(cbk_info);
+	rtype = CADR(cbk_info);
+	argtypes = CADDR(cbk_info);
+
+	arg_buffer += 4; /* Skip return address */
+	for (i=0; !endp(argtypes); argtypes = CDR(argtypes), i++) {
+		tag = ecl_foreign_type_code(CAR(argtypes));
+		size = fix(si_size_of_foreign_elt_type(CAR(argtypes)));
+		result = ecl_foreign_data_ref_elt(arg_buffer, tag);
+		cl_stack_push(result);
+		{
+			int mask = 3;
+			int sp = (size + mask) & ~mask;
+			arg_buffer += (size+sp);
+		}
+	}
+
+	result = cl_apply_from_stack(i, fun);
+	cl_stack_pop_n(i);
+
+	tag = ecl_foreign_type_code(rtype);
+	memset(&output, 0, sizeof(output));
+	ecl_foreign_data_set_elt(&output, tag, result);
+
+	switch (tag) {
+	case ECL_FFI_CHAR: i = output.c; goto INT;
+	case ECL_FFI_UNSIGNED_CHAR: i = output.uc; goto INT;
+	case ECL_FFI_BYTE: i = output.b; goto INT;
+	case ECL_FFI_UNSIGNED_BYTE: i = output.ub; goto INT;
+	case ECL_FFI_SHORT: i = output.s; goto INT;
+	case ECL_FFI_UNSIGNED_SHORT: i = output.us; goto INT;
+	case ECL_FFI_POINTER_VOID:
+	case ECL_FFI_OBJECT:
+	case ECL_FFI_CSTRING:
+	case ECL_FFI_INT:
+	case ECL_FFI_UNSIGNED_INT:
+	case ECL_FFI_LONG:
+	case ECL_FFI_UNSIGNED_LONG:
+		i = output.i;
+INT:
+#ifdef _MSC_VER
+		__asm mov eax,i
+#else
+		{
+		register int eax asm("eax");
+		eax = i;
+		return;
+		}
+#endif
+	case ECL_FFI_DOUBLE: {
+#ifdef _MSC_VER
+		__asm fld output.d
+#else
+		{
+		asm("fldl (%0)" :: "a" (&output.d));
+		return;
+		}
+#endif
+	}
+	case ECL_FFI_FLOAT: {
+#ifdef _MSC_VER
+		__asm fld output.f
+#else
+		{
+		asm("flds (%0)" :: "a" (&output.f));
+		return;
+		}
+#endif
+		return;
+	}
+	case ECL_FFI_VOID:
+		return;
+	}
+}
+
+void*
+ecl_dynamic_callback_make(cl_object data)
+{
+	/*
+	 *	push	%esp				54
+	 *	pushl	<data>				68 <addr32>
+	 *	call	ecl_dynamic_callback_call	E8 <disp32>
+	 * [ Here we could use also lea 4(%esp), %esp, but %ecx seems to be free ]
+	 *	pop	%ecx				59
+	 *	pop	%ecx				59
+	 *	ret					c3
+	 *	nop					90
+	 *	nop					90
+	 */
+	char *buf = (char*)cl_alloc_atomic_align(sizeof(char)*16, 4);
+	*(char*) (buf+0)  = 0x54;
+	*(char*) (buf+1)  = 0x68;
+	*(long*) (buf+2)  = (long)data;
+	*(char*) (buf+6)  = 0xE8;
+	*(long*) (buf+7)  = (long)ecl_dynamic_callback_execute - (long)(buf+11);
+	*(char*) (buf+11) = 0x59;
+	*(char*) (buf+12) = 0x59;
+	*(char*) (buf+13) = 0xc3;
+	*(short*)(buf+14) = 0x9090;
+
+	return buf;
+}

src/c/cinit.d

@@ -22,16 +22,13 @@ 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);
-}
-
 extern cl_object
 cl_vector_push_extend(cl_narg narg, cl_object elt, cl_object vector, ...)
 {
-	return funcall(2, @'VECTOR-PUSH-EXTEND', vector, elt);
+	if (narg != 2) {
+		FEerror("Too many arguments to interim cl_vector_push_extend (cinit.d)", 0);
+	}
+	return funcall(2, @'VECTOR-PUSH-EXTEND', elt, vector);
 }
 
 static cl_object si_simple_toplevel ()

src/c/ffi.d

@@ -415,7 +415,7 @@ si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_objec
 
 	block = (module == @':default' ? module : si_load_foreign_module(module));
 	var = ecl_null_terminated_string(var);
-	sym = ecl_library_symbol(block, var->string.self);
+	sym = ecl_library_symbol(block, var->string.self, 1);
 	if (sym == NULL) {
 		if (block != @':default')
 			output = ecl_library_error(block);
@@ -519,4 +519,15 @@ si_call_cfun(cl_object fun, cl_object return_type, cl_object arg_types,
 	@(return object)
 }
 
+cl_object
+si_make_dynamic_callback(cl_object fun, cl_object sym, cl_object rtype, cl_object argtypes)
+{
+	cl_object data = CONS(fun, CONS(rtype, CONS(argtypes, Cnil)));
+	cl_object cbk  = ecl_make_foreign_data(@':pointer-void', 0, ecl_dynamic_callback_make(data));
+
+	si_put_sysprop(sym, @':callback', CONS(cbk, data));
+	@(return cbk)
+}
+
+
 #endif /* ECL_DYNAMIC_FFI */

src/c/gbc.d

@@ -506,6 +506,7 @@ static void
 mark_phase(void)
 {
 	int i;
+	cl_object s;
 
 	/* save registers on the stack */
 	jmp_buf volatile registers;
@@ -513,22 +514,30 @@ mark_phase(void)
 
 	/* mark registered symbols & keywords */
 	for (i=0; i<cl_num_symbols_in_core; i++) {
-		cl_object s = (cl_object)(cl_symbols + i);
+		s = (cl_object)(cl_symbols + i);
 		s->symbol.m = FALSE;
 	}
 	for (i=0; i<cl_num_symbols_in_core; i++) {
-		cl_object s = (cl_object)(cl_symbols + i);
+		s = (cl_object)(cl_symbols + i);
 		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.libraries + 1));
-	cl_core.libraries->vector.elttype = aet_object;
-
+	s = cl_core.libraries;
+	if (s) {
+		for (i = 0; i < s->vector.fillp; i++) {
+			cl_object dll = s->vector.self.t[i];
+			if (dll->cblock.locked) {
+				mark_object(dll);
+			}
+		}
+		s->vector.elttype = aet_fix;
+		mark_object(s);
+		s->vector.elttype = aet_object;
+	}
+	mark_stack_conservative((cl_ptr)&cl_core, (cl_ptr)(&cl_core + 1));
 	/* mark roots */
 	for (i = 0; i < gc_roots;  i++)
 		mark_object(*gc_root[i]);

src/c/load.d

@@ -78,9 +78,22 @@ ecl_library_open(cl_object filename) {
 }
 
 void *
-ecl_library_symbol(cl_object block, const char *symbol) {
+ecl_library_symbol(cl_object block, const char *symbol, bool lock) {
+	void *p;
 	if (block == @':default') {
+		cl_object l = cl_core.libraries;
+		if (l) {
+			cl_index i;
+			for (i = 0; i < l->vector.fillp; i++) {
+				cl_object block = l->vector.self.t[i];
+				p = ecl_library_symbol(block, symbol, lock);
+				if (p) {
+					return p;
+				}
+			}
+		}
 #if defined(mingw32) || defined(_MSC_VER)
+ 		{
 		HANDLE hndSnap = NULL;
 		HANDLE hnd = NULL;
 		hndSnap = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId());
@@ -97,25 +110,39 @@ ecl_library_symbol(cl_object block, const char *symbol) {
 			CloseHandle(hndSnap);
 		}
 		return hnd;
+		}
 #endif
 #ifdef HAVE_DLFCN_H
 		return dlsym(0, symbol);
+#endif
+#if !defined(mingw32) && !defined(_MSC_VER) && !defined(HAVE_DLFCN_H)
+		return 0;
 #endif
 	} else {
 #ifdef HAVE_DLFCN_H
-		return dlsym(block->cblock.handle, symbol);
+		p = dlsym(block->cblock.handle, symbol);
 #endif
 #if defined(mingw32) || defined(_MSC_VER)
 		HMODULE h = (HMODULE)(block->cblock.handle);
-		return GetProcAddress(h, symbol);
+		p = GetProcAddress(h, symbol);
 #endif
 #ifdef HAVE_MACH_O_DYLD_H
 		NSSymbol sym;
 		sym = NSLookupSymbolInModule((NSModule)(block->cblock.handle),
 					     symbol);
-		if (sym == 0) return 0;
-		return (void*)NSAddressOfSymbol(sym);
+		if (sym == 0) {
+			p = 0;
+		} else {
+			p = NSAddressOfSymbol(sym);
+		}
 #endif
+		/* Libraries whose symbols are being referenced by the FFI should not
+		 * get garbage collected. Until we find a better solution we simply lock
+		 * them for the rest of the runtime */
+		if (p) {
+			block->cblock.locked |= lock;
+		}
+		return p;
 	}
 }
 
@@ -226,7 +253,7 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print)
 	}
 
 	/* Fist try to call "init_CODE()" */
-	block->cblock.entry = ecl_library_symbol(block, INIT_PREFIX "CODE");
+	block->cblock.entry = ecl_library_symbol(block, INIT_PREFIX "CODE", 0);
 	if (block->cblock.entry != NULL)
 		goto GO_ON;
 
@@ -241,7 +268,7 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print)
 						 make_constant_string("_"));
 	basename = cl_pathname_name(1,filename);
 	basename = @si::string-concatenate(2, prefix, @string-upcase(1, funcall(4, @'nsubstitute', CODE_CHAR('_'), CODE_CHAR('-'), basename)));
-	block->cblock.entry = ecl_library_symbol(block, basename->string.self);
+	block->cblock.entry = ecl_library_symbol(block, basename->string.self, 0);
 
 	if (block->cblock.entry == NULL) {
 		output = ecl_library_error(block);

src/c/main.d

@@ -290,6 +290,8 @@ cl_boot(int argc, char **argv)
 	cl_core.gentemp_prefix = make_constant_string("T");
 	cl_core.gentemp_counter = MAKE_FIXNUM(0);
 
+	/* LIBRARIES is an adjustable vector of objects. It behaves as a vector of
+	   weak pointers thanks to the magic in gbc.d/alloc_2.d */
 	cl_core.libraries = si_make_vector(@'t', MAKE_FIXNUM(0),
 					   @'t', MAKE_FIXNUM(0),
 					   @'nil', @'nil');

src/c/symbols_list.h

@@ -1555,7 +1555,8 @@ cl_symbols[] = {
 #ifdef ECL_DYNAMIC_FFI
 {SYS_ "CALL-CFUN", SI_ORDINARY, si_call_cfun, 4, OBJNULL},
 {KEY_ "CALLBACK", KEYWORD, NULL, -1, OBJNULL},
-#endif  /* ECL_DYNAMIC_FFI */
+{SYS_ "MAKE-DYNAMIC-CALLBACK", SI_ORDINARY, si_make_dynamic_callback, 4, OBJNULL},
+#endif
 
 /* Tag for end of list */
 {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

src/c/symbols_list2.h

@@ -1552,11 +1552,10 @@ cl_symbols[] = {
 
 {SYS_ "*CODE-WALKER*",NULL},
 
-#ifdef ECL_DYNAMIC_FFI
 {SYS_ "CALL-CFUN","si_call_cfun"},
 {KEY_ "CALLBACK",NULL},
-#endif  /* ECL_DYNAMIC_FFI */
 
+{SYS_ "MAKE-DYNAMIC-CALLBACK","si_make_dynamic_callback"},
 /* Tag for end of list */
 {NULL,NULL}};