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

@@ -1,6 +1,12 @@
 ECL 0.9h
 ========
 
+* Errors fixed:
+
+ - The garbage collection of FASL files had been deactivated by the use of
+   high level routines (VECTOR-PUSH-EXTEND) to handle the vector of weak
+   pointers to the files.
+
 * Design:
 
  - Simplified the structure of the frame stack, removing redundant fields.
@@ -52,6 +58,10 @@ ECL 0.9h
    initialization files; errors during initialization are intercepted and cause
    ECL to abort.
 
+ - Replacing GC_malloc with GC_malloc_ignore_offset() makes ECL use less
+   memory. A 30% reduction observed when running the ANSI compatibility test
+   suite.
+
 * Foreign function interface (FFI):
 
  - Foreign function return type is now correctly handled, when it is specified
@@ -72,6 +82,9 @@ ECL 0.9h
 	(ffi:defcallback foo :int ((a :int))
 	   (1+ a))
 
+ - On the intel x86 architecture we also have the possibility of creating
+   callbacks dynamically, at run time, without the compiler.
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***

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

src/cmp/cmpcbk.lsp

@@ -35,9 +35,10 @@
        `(progn
 	 (defun ,name ,arg-variables ,@body)
 	 (si::put-sysprop ',name :callback
+	  (list
 	  (ffi:c-inline () () :object
 	   ,(format nil "ecl_make_foreign_data(@':pointer-void,0,~a)" c-name)
-	   :one-liner t))))
+	   :one-liner t)))))
       )))
 
 (defconstant +foreign-elt-type-codes+

src/cmp/cmpffi.lsp

@@ -263,8 +263,8 @@
 		(elt arg-types ndx) :char*)
 	  (return-from c1c-inline
 	    (c1expr
-	     `(ffi::with-cstring (,var ,value)
-	       (c-inline ,arguments ,arg-types ,output-type ,c-expression
+	     `(ffi::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}*)

src/cmp/cmpmain.lsp

@@ -330,7 +330,7 @@ static cl_object VV[VM];
        #-(or :win32 :mingw32 :darwin)
        (setf submodules
 	     (mapcar #'(lambda (sm)
-			 (format nil "((ecl_init_function_t) ecl_library_symbol(Cblock, \"~A\"))" sm))
+			 (format nil "((ecl_init_function_t) ecl_library_symbol(Cblock, \"~A\", 0))" sm))
 		     submodules))
        (format c-file +lisp-program-init+ init-name prologue-code shared-data-file
 	       submodules epilogue-code)

src/h/external.h

@@ -168,11 +168,11 @@ struct cl_core_struct {
 
 	cl_object system_properties;
 
-	cl_object libraries;
 #ifdef ECL_THREADS
 	cl_object processes;
 	pthread_mutex_t global_lock;
 #endif
+	cl_object libraries;
 };
 
 #if defined(mingw32) || defined(_MSC_VER) || defined(cygwin)
@@ -190,16 +190,16 @@ extern void cl_dealloc(void *p, cl_index s);
 extern cl_object si_gc(cl_object area);
 extern cl_object si_gc_dump(void);
 #ifdef _MSC_VER
-extern char *GC_malloc(size_t size);
+extern char *GC_malloc_ignore_off_page(size_t size);
 extern char *GC_malloc_atomic_ignore_off_page(size_t size);
 #else
-extern void *GC_malloc(size_t size);
+extern void *GC_malloc_ignore_off_page(size_t size);
 extern void *GC_malloc_atomic_ignore_off_page(size_t size);
 #endif
 extern void GC_free(void *);
-#define cl_alloc GC_malloc
+#define cl_alloc GC_malloc_ignore_off_page
 #define cl_alloc_atomic GC_malloc_atomic_ignore_off_page
-#define cl_alloc_align(s,d) GC_malloc(s)
+#define cl_alloc_align(s,d) GC_malloc_ignore_off_page(s)
 #define cl_alloc_atomic_align(s,d) GC_malloc_atomic_ignore_off_page(s)
 #define cl_dealloc(p,s)
 #define ecl_register_static_root(x) ecl_register_root(x)
@@ -509,6 +509,7 @@ extern cl_object si_size_of_foreign_elt_type(cl_object tag);
 extern cl_object si_load_foreign_module(cl_object module);
 extern cl_object si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_object size);
 extern cl_object si_call_cfun(cl_object fun, cl_object return_type, cl_object arg_types, cl_object args);
+extern cl_object si_make_dynamic_callback(cl_object fun, cl_object sym, cl_object return_type, cl_object arg_types);
 
 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);
@@ -777,7 +778,7 @@ extern void ecl_delete_eq(cl_object x, cl_object *l);
 /* load.c */
 
 extern cl_object ecl_library_open(cl_object filename);
-extern void *ecl_library_symbol(cl_object block, const char *symbol);
+extern void *ecl_library_symbol(cl_object block, const char *symbol, bool lock);
 extern cl_object ecl_library_error(cl_object block);
 extern void ecl_library_close(cl_object block);
 extern void ecl_library_close_all(void);

src/h/internal.h

@@ -127,6 +127,8 @@ void ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag type, cl_object value);
 
 void ecl_fficall_push_arg(union ecl_ffi_values *data, enum ecl_ffi_tag type);
 void ecl_fficall_execute(void *f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag return_type);
+void ecl_dynamic_callback_call(cl_object callback_info, char* buffer);
+void* ecl_dynamic_callback_make(cl_object data);
 
 /* file.d */
 

src/h/object.h

@@ -394,7 +394,8 @@ struct ecl_pathname {
 };
 
 struct ecl_codeblock {
-	HEADER1(self_destruct);		/*  delete DLL after gc */
+	HEADER2(self_destruct,locked);	/*  delete DLL after gc */
+					/*  do not garbage collect this library */
 	void	*handle;		/*  handle returned by dlopen  */
 	void	*entry;			/*  entry point  */
  	cl_object *data;		/*  data vector  */

src/lsp/ffi.lsp

@@ -634,14 +634,23 @@
 ;;; CALLBACKS
 ;;;
 
+#-dffi
 (defmacro defcallback (&rest args)
   (error "DEFCALLBACK cannot be used in interpreted forms"))
 
+#+dffi
+(defmacro defcallback (name ret-type arg-desc &body body)
+  (let ((arg-types (mapcar #'second arg-desc))
+	(arg-names (mapcar #'first arg-desc)))
+  `(si::make-dynamic-callback
+    #'(ext::lambda-block ,name ,arg-names ,@body)
+    ',name ',ret-type ',arg-types)))
+
 (defun callback (name)
   (let ((x (si::get-sysprop name :callback)))
     (unless x
       (error "There is no callback with name ~a" name))
-    x))
+    (first x)))
 
 ;;;----------------------------------------------------------------------
 ;;; COMPATIBILITY WITH OLDER FFI