Implement controllable calling convention for FFI/callbacks.

src/c/arch/ffi_x86.d

@@ -91,11 +91,14 @@ ecl_fficall_execute(void *f_ptr, struct ecl_fficall *fficall, enum ecl_ffi_tag r
 	} else {
 		((void (*)())f_ptr)();
 	}
+
+	if (fficall->cc == ECL_FFI_CC_CDECL) {
 #ifdef _MSC_VER
-	__asm add esp,bufsize
+		__asm add esp,bufsize
 #else
-	sp += fficall->buffer_size;
+		sp += fficall->buffer_size;
 #endif
+	}
 }
 
 static void
@@ -182,7 +185,7 @@ INT:
 }
 
 void*
-ecl_dynamic_callback_make(cl_object data)
+ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_type)
 {
 	/*
 	 *	push	%esp				54
@@ -203,8 +206,23 @@ ecl_dynamic_callback_make(cl_object data)
 	*(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;
+	if (cc_type == ECL_FFI_CC_CDECL) {
+		*(char*) (buf+13) = 0xc3;
+		*(short*)(buf+14) = 0x9090;
+	} else {
+		cl_object arg_types = CADDR(data);
+		int byte_size = 0;
+		int mask = 3;
+
+		while (CONSP(arg_types)) {
+			int sz = fix(si_size_of_foreign_elt_type(CAR(arg_types)));
+			byte_size += ((sz+mask)&(~mask));
+			arg_types = CDR(arg_types);
+		}
+
+		*(char*) (buf+13) = 0xc2;
+		*(short*)(buf+14) = (short)byte_size;
+	}
 
 	return buf;
 }

src/c/ffi.d

@@ -34,6 +34,11 @@ static const cl_object ecl_foreign_type_table[] = {
 	@':double',
 	@':void'};
 
+static const cl_object ecl_foreign_cc_table[] = {
+	@':cdecl',
+	@':stdcall'
+};
+
 static unsigned int ecl_foreign_type_size[] = {
 	sizeof(char),
 	sizeof(unsigned char),
@@ -219,6 +224,18 @@ ecl_foreign_type_code(cl_object type)
 	return ECL_FFI_VOID;
 }
 
+enum ecl_ffi_calling_convention
+ecl_foreign_cc_code(cl_object cc)
+{
+	int i;
+	for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) {
+		if (cc == ecl_foreign_cc_table[i])
+			return (enum ecl_ffi_calling_convention)i;
+	}
+	FEerror("~A does no denote a valid calling convention.", 1, cc);
+	return ECL_FFI_CC_CDECL;
+}
+
 cl_object
 ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag)
 {
@@ -438,12 +455,13 @@ ecl_fficall_overflow()
 }
 
 void
-ecl_fficall_prepare(cl_object return_type, cl_object arg_type)
+ecl_fficall_prepare(cl_object return_type, cl_object arg_type, cl_object cc_type)
 {
 	struct ecl_fficall *fficall = cl_env.fficall;
 	fficall->buffer_sp = fficall->buffer;
 	fficall->buffer_size = 0;
 	fficall->cstring = Cnil;
+	fficall->cc = ecl_foreign_cc_code(cc_type);
 }
 
 void
@@ -480,16 +498,14 @@ ecl_fficall_align(int data)
 	}
 }
 
-cl_object
-si_call_cfun(cl_object fun, cl_object return_type, cl_object arg_types,
-	     cl_object args)
-{
+@(defun si::call-cfun (fun return_type arg_types args &optional (cc_type @':cdecl'))
 	struct ecl_fficall *fficall = cl_env.fficall;
 	void *cfun = ecl_foreign_data_pointer_safe(fun);
 	cl_object object;
 	enum ecl_ffi_tag return_type_tag = ecl_foreign_type_code(return_type);
+@
 
-	ecl_fficall_prepare(return_type, arg_types);
+	ecl_fficall_prepare(return_type, arg_types, cc_type);
 	while (CONSP(arg_types)) {
 		enum ecl_ffi_tag type;
 		if (!CONSP(args)) {
@@ -517,17 +533,18 @@ si_call_cfun(cl_object fun, cl_object return_type, cl_object arg_types,
 	fficall->cstring = Cnil;
 
 	@(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));
+@(defun si::make-dynamic-callback (fun sym rtype argtypes &optional (cctype @':cdecl'))
+	cl_object data;
+	cl_object cbk;
+@
+	data = CONS(fun, CONS(rtype, CONS(argtypes, Cnil)));
+	cbk  = ecl_make_foreign_data(@':pointer-void', 0, ecl_dynamic_callback_make(data, ecl_foreign_cc_code(cctype)));
 
 	si_put_sysprop(sym, @':callback', CONS(cbk, data));
 	@(return cbk)
-}
+@)
 
 
 #endif /* ECL_DYNAMIC_FFI */

src/c/symbols_list.h

@@ -1553,10 +1553,12 @@ cl_symbols[] = {
 {SYS_ "*CODE-WALKER*", SI_SPECIAL, NULL, -1, OBJNULL},
 
 #ifdef ECL_DYNAMIC_FFI
-{SYS_ "CALL-CFUN", SI_ORDINARY, si_call_cfun, 4, OBJNULL},
+{SYS_ "CALL-CFUN", SI_ORDINARY, si_call_cfun, -1, OBJNULL},
 {KEY_ "CALLBACK", KEYWORD, NULL, -1, OBJNULL},
-{SYS_ "MAKE-DYNAMIC-CALLBACK", SI_ORDINARY, si_make_dynamic_callback, 4, OBJNULL},
+{SYS_ "MAKE-DYNAMIC-CALLBACK", SI_ORDINARY, si_make_dynamic_callback, -1, OBJNULL},
 #endif
+{KEY_ "CDECL", KEYWORD, NULL, -1, OBJNULL},
+{KEY_ "STDCALL", KEYWORD, NULL, -1, OBJNULL},
 
 /* Tag for end of list */
 {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

src/c/symbols_list2.h

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

src/cmp/cmpcbk.lsp

@@ -17,7 +17,9 @@
     (let ((arg-types '())
 	  (arg-type-constants '())
 	  (arg-variables '())
-	  (c-name (format nil "ecl_callback_~d" (length *callbacks*))))
+	  (c-name (format nil "ecl_callback_~d" (length *callbacks*)))
+	  (name (if (consp name) (first name) name))
+	  (call-type (if (consp name) (second name) :cdecl)))
       (dolist (i arg-list)
 	(unless (consp i)
 	  (cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i))
@@ -29,7 +31,7 @@
 		    (add-object type))
 		arg-type-constants)))
       (push (list name c-name (add-object name)
-		  return-type (reverse arg-types) (reverse arg-type-constants))
+		  return-type (reverse arg-types) (reverse arg-type-constants) call-type)
 	    *callbacks*)
       (c1expr
        `(progn
@@ -66,7 +68,7 @@
     (cdr x)))
 
 (defun t3-defcallback (lisp-name c-name c-name-constant return-type
-		       arg-types arg-type-constants)
+		       arg-types arg-type-constants call-type)
   (cond ((ffi::foreign-elt-type-p return-type))
 	((and (consp return-type)
 	      (member (first return-type) '(* array)))
@@ -74,8 +76,13 @@
 	(t
 	 (cmperr "DEFCALLBACK does not support complex return types such as ~A"
 		 return-type)))
-  (let ((return-type-name (rep-type-name (ffi::%convert-to-arg-type return-type))))
-    (wt-nl1 return-type-name " " c-name "(")
+  (let ((return-type-name (rep-type-name (ffi::%convert-to-arg-type return-type)))
+	(fmod (case call-type
+		(:cdecl "")
+		(:stdcall "__stdcall ")
+		(t (cmperr "DEFCALLBACK does not support ~A as calling convention"
+			   call-type)))))
+    (wt-nl1 return-type-name " " fmod c-name "(")
     (loop for n from 0
 	  and type in arg-types
 	  with comma = ""

src/h/internal.h

@@ -109,16 +109,23 @@ union ecl_ffi_values {
 	double d;
 };
 
+enum ecl_ffi_calling_convention {
+	ECL_FFI_CC_CDECL = 0,
+	ECL_FFI_CC_STDCALL
+};
+
 struct ecl_fficall {
 	char *buffer_sp;
 	size_t buffer_size;
 	union ecl_ffi_values output;
+	enum ecl_ffi_calling_conventions cc;
 	char buffer[ECL_FFICALL_LIMIT];
 	cl_object cstring;
 };
 
 enum ecl_ffi_tag ecl_foreign_type_code(cl_object type);
-void ecl_fficall_prepare(cl_object return_type, cl_object arg_types);
+enum ecl_ffi_calling_convention ecl_foreign_cc_code(cl_object cc_type);
+void ecl_fficall_prepare(cl_object return_type, cl_object arg_types, cl_object cc_type);
 void ecl_fficall_push_bytes(void *data, size_t bytes);
 void ecl_fficall_push_int(int word);
 void ecl_fficall_align(int data);
@@ -128,7 +135,7 @@ 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);
+void* ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_type);
 
 /* file.d */
 

src/lsp/ffi.lsp

@@ -511,7 +511,7 @@
 
 ;;; FIXME! We should turn this into a closure generator that produces no code.
 #+DFFI
-(defmacro def-lib-function (name args &key returning module)
+(defmacro def-lib-function (name args &key returning module (call :cdecl))
   (multiple-value-bind (c-name lisp-name) (if (consp name)
 					    (values-list name)
 					    (values (string name) name))
@@ -520,13 +520,13 @@
 	   (argtypes (mapcar #'(lambda (a) (ffi::%convert-to-arg-type (second a))) args)))
       `(let ((c-fun (si::find-foreign-symbol ,c-name ,module :pointer-void 0)))
 	(defun ,lisp-name ,(mapcar #'first args)
-	  (si::call-cfun c-fun ',return-type ',argtypes (list ,@(mapcar #'first args))))))))
+	  (si::call-cfun c-fun ',return-type ',argtypes (list ,@(mapcar #'first args)) ,call))))))
 
-(defmacro def-function (name args &key module (returning :void))
+(defmacro def-function (name args &key module (returning :void) (call :cdecl))
   #+DFFI
   (when module
     (return-from def-function
-      `(def-lib-function ,name ,args :returning ,returning :module ,module)))
+      `(def-lib-function ,name ,args :returning ,returning :module ,module :call ,call)))
   (multiple-value-bind (c-name lisp-name)
       (lisp-to-c-name name)
     (let* ((arguments (mapcar #'first args))
@@ -640,11 +640,14 @@
 
 #+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)))
+  (multiple-value-bind (name call-type) (if (consp name)
+					  (values-list name)
+					  (values name :cdecl))
+    (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 ,call-type))))
 
 (defun callback (name)
   (let ((x (si::get-sysprop name :callback)))