From 0ee18977e01dbffcd74ef856c99be9fa350532da Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 17 Oct 2005 10:29:33 +0000 Subject: [PATCH] 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 | 13 +++++ src/c/alloc.d | 1 + src/c/alloc_2.d | 20 ++++++-- src/c/arch/ffi_x86.d | 113 ++++++++++++++++++++++++++++++++++++++++++ src/c/cinit.d | 11 ++-- src/c/ffi.d | 13 ++++- src/c/gbc.d | 23 ++++++--- src/c/load.d | 41 ++++++++++++--- src/c/main.d | 2 + src/c/symbols_list.h | 3 +- src/c/symbols_list2.h | 3 +- src/cmp/cmpcbk.lsp | 3 +- src/cmp/cmpffi.lsp | 4 +- src/cmp/cmpmain.lsp | 2 +- src/h/external.h | 13 ++--- src/h/internal.h | 2 + src/h/object.h | 3 +- src/lsp/ffi.lsp | 11 +++- 18 files changed, 241 insertions(+), 40 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 340cd3464..545adac57 100644 --- a/src/CHANGELOG +++ b/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 *** diff --git a/src/c/alloc.d b/src/c/alloc.d index 4e3b4cb26..9a6c8603f 100644 --- a/src/c/alloc.d +++ b/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; diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 8f4059ae4..0c1a2a05a 100644 --- a/src/c/alloc_2.d +++ b/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)(); } diff --git a/src/c/arch/ffi_x86.d b/src/c/arch/ffi_x86.d index 37e850a01..e5f94214e 100644 --- a/src/c/arch/ffi_x86.d +++ b/src/c/arch/ffi_x86.d @@ -13,6 +13,7 @@ */ #include +#include #include 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 68 + * call ecl_dynamic_callback_call E8 + * [ 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; +} diff --git a/src/c/cinit.d b/src/c/cinit.d index 6b95fc3f6..0dd59bcd4 100644 --- a/src/c/cinit.d +++ b/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 () diff --git a/src/c/ffi.d b/src/c/ffi.d index 5cf30700e..7be36ac24 100644 --- a/src/c/ffi.d +++ b/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 */ diff --git a/src/c/gbc.d b/src/c/gbc.d index ff0e766c5..e81b2c612 100644 --- a/src/c/gbc.d +++ b/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; isymbol.m = FALSE; } for (i=0; ivector.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]); diff --git a/src/c/load.d b/src/c/load.d index 51722aad0..9736dc2ab 100644 --- a/src/c/load.d +++ b/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); diff --git a/src/c/main.d b/src/c/main.d index 3d88d8c6c..7723c4ff6 100644 --- a/src/c/main.d +++ b/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'); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 56080722d..020f53167 100644 --- a/src/c/symbols_list.h +++ b/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}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 6961a582e..6808476c2 100644 --- a/src/c/symbols_list2.h +++ b/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}}; diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index db1cdcb6a..facf22143 100644 --- a/src/cmp/cmpcbk.lsp +++ b/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+ diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 8b745d871..60192d4b6 100644 --- a/src/cmp/cmpffi.lsp +++ b/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}*) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 66041d435..2feeceb81 100644 --- a/src/cmp/cmpmain.lsp +++ b/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) diff --git a/src/h/external.h b/src/h/external.h index 940a64995..1e093b889 100644 --- a/src/h/external.h +++ b/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); diff --git a/src/h/internal.h b/src/h/internal.h index 77818222b..5d8d84006 100644 --- a/src/h/internal.h +++ b/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 */ diff --git a/src/h/object.h b/src/h/object.h index 6119bf423..153b3864d 100644 --- a/src/h/object.h +++ b/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 */ diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index b6c454142..8b1197e50 100644 --- a/src/lsp/ffi.lsp +++ b/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