Add STDCALL alien convention support for Windows

Thanks to Anton Kovalenko.

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index eb883db..8e61909 100644 (file)
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -1137,27 +1137,68 @@
 \f
 ;;;; the FUNCTION and VALUES alien types
 
+;;; Calling-convention spec, typically one of predefined keywords.
+;;; Add or remove as needed for target platform.  It makes sense to
+;;; support :cdecl everywhere.
+;;;
+;;; Null convention is supposed to be platform-specific most-universal
+;;; callout convention. For x86, SBCL calls foreign functions in a way
+;;; allowing them to be either stdcall or cdecl; null convention is
+;;; appropriate here, as it is for specifying callbacks that could be
+;;; accepted by foreign code both in cdecl and stdcall form.
+(def!type calling-convention () `(or null (member :stdcall :cdecl)))
+
+;;; Convention could be a values type class, stored at result-type.
+;;; However, it seems appropriate only for epilogue-related
+;;; conventions, those not influencing incoming arg passing.
+;;;
+;;; As of x86's :stdcall and :cdecl, supported by now, both are
+;;; epilogue-related, but future extensions (like :fastcall and
+;;; miscellaneous non-x86 stuff) might affect incoming argument
+;;; translation as well.
+
 (define-alien-type-class (fun :include mem-block)
   (result-type (missing-arg) :type alien-type)
   (arg-types (missing-arg) :type list)
-  (stub nil :type (or null function)))
+  (stub nil :type (or null function))
+  (convention nil :type calling-convention))
+
+;;; KLUDGE: non-intrusive, backward-compatible way to allow calling
+;;; convention specification for function types is unobvious.
+;;;
+;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list
+;;; starting with a convention keyword; its second item is a real
+;;; result-type in this case. If convention is ever to become a part
+;;; of result-type, such a syntax can be retained.
 
 (define-alien-type-translator function (result-type &rest arg-types
                                                     &environment env)
-  (make-alien-fun-type
-   :result-type (let ((*values-type-okay* t))
-                  (parse-alien-type result-type env))
-   :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
-                      arg-types)))
+  (multiple-value-bind (bare-result-type calling-convention)
+      (typecase result-type
+        ((cons calling-convention *)
+           (values (second result-type) (first result-type)))
+        (t result-type))
+    (make-alien-fun-type
+     :convention calling-convention
+     :result-type (let ((*values-type-okay* t))
+                    (parse-alien-type bare-result-type env))
+     :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
+                        arg-types))))
 
 (define-alien-type-method (fun :unparse) (type)
-  `(function ,(%unparse-alien-type (alien-fun-type-result-type type))
+  `(function ,(let ((result-type
+                     (%unparse-alien-type (alien-fun-type-result-type type)))
+                    (convention (alien-fun-type-convention type)))
+                (if convention (list convention result-type)
+                    result-type))
              ,@(mapcar #'%unparse-alien-type
                        (alien-fun-type-arg-types type))))
 
 (define-alien-type-method (fun :type=) (type1 type2)
   (and (alien-type-= (alien-fun-type-result-type type1)
                      (alien-fun-type-result-type type2))
+       (eq (alien-fun-type-convention type1)
+           (alien-fun-type-convention type2))
        (= (length (alien-fun-type-arg-types type1))
           (length (alien-fun-type-arg-types type2)))
        (every #'alien-type-=

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index 7e9b25e..e746b72 100644 (file)
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -867,8 +867,10 @@ we don't create new wrappers if one for the same specifier already exists.")
   "Lisp trampoline store: assembler wrappers contain indexes to this, and
 ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
 
-(defun %alien-callback-sap (specifier result-type argument-types function wrapper)
-  (let ((key (cons specifier function)))
+(defun %alien-callback-sap (specifier result-type argument-types function wrapper
+                            &optional call-type)
+  (declare #!-x86 (ignore call-type))
+  (let ((key (list specifier function)))
     (or (gethash key *alien-callbacks*)
         (setf (gethash key *alien-callbacks*)
               (let* ((index (fill-pointer *alien-callback-trampolines*))
@@ -879,8 +881,17 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
                      ;; per-function tramp would need assembler at
                      ;; runtime. Possibly we could even pregenerate
                      ;; the code and just patch the index in later.
-                     (assembler-wrapper (alien-callback-assembler-wrapper
-                                         index result-type argument-types)))
+                     (assembler-wrapper
+                      (alien-callback-assembler-wrapper
+                       index result-type argument-types
+                       #!+x86
+                       (if (eq call-type :stdcall)
+                           (ceiling
+                            (apply #'+
+                                   (mapcar 'alien-type-word-aligned-bits
+                                           argument-types))
+                            8)
+                           0))))
                 (vector-push-extend
                  (alien-callback-lisp-trampoline wrapper function)
                  *alien-callback-trampolines*)
@@ -959,11 +970,17 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
   (destructuring-bind (function result-type &rest argument-types)
       specifier
     (aver (eq 'function function))
-    (values (let ((*values-type-okay* t))
-              (parse-alien-type result-type env))
-            (mapcar (lambda (spec)
-                      (parse-alien-type spec env))
-                    argument-types))))
+    (multiple-value-bind (bare-result-type calling-convention)
+        (typecase result-type
+          ((cons calling-convention *)
+             (values (second result-type) (first result-type)))
+          (t result-type))
+      (values (let ((*values-type-okay* t))
+                (parse-alien-type bare-result-type env))
+              (mapcar (lambda (spec)
+                        (parse-alien-type spec env))
+                      argument-types)
+              calling-convention))))
 
 (defun alien-void-type-p (type)
   (and (alien-values-type-p type) (not (alien-values-type-values type))))
@@ -999,7 +1016,8 @@ SPECIFIER and FUNCTION already exists, it is returned instead of consing a new
 one."
   ;; Pull out as much work as is convenient to macro-expansion time, specifically
   ;; everything that can be done given just the SPECIFIER and ENV.
-  (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env)
+  (multiple-value-bind (result-type argument-types call-type)
+      (parse-alien-ftype specifier env)
     `(%sap-alien
       (%alien-callback-sap ',specifier ',result-type ',argument-types
                            ,function
@@ -1007,7 +1025,8 @@ one."
                                (setf (gethash ',specifier *alien-callback-wrappers*)
                                      (compile nil
                                               ',(alien-callback-lisp-wrapper-lambda
-                                                 specifier result-type argument-types env)))))
+                                                 specifier result-type argument-types env))))
+                           ,call-type)
       ',(parse-alien-type specifier env))))
 
 (defun alien-callback-p (alien)

diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index 8cd0e07..4d57b8e 100644 (file)
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -403,7 +403,8 @@
   `(deref (sap-alien (sap+ ,sp ,offset) (* ,type))))
 
 #-sb-xc-host
-(defun alien-callback-assembler-wrapper (index return-type arg-types)
+(defun alien-callback-assembler-wrapper
+    (index return-type arg-types &optional (stack-offset 0))
   "Cons up a piece of code which calls call-callback with INDEX and a
 pointer to the arguments."
   (declare (ignore arg-types))
@@ -461,7 +462,7 @@ pointer to the arguments."
                  (error "unrecognized alien type: ~A" return-type)))
               (inst mov esp ebp)                   ; discard frame
               (inst pop ebp)                       ; restore frame pointer
-              (inst ret))
+              (inst ret stack-offset))
     (finalize-segment segment)
     ;; Now that the segment is done, convert it to a static
     ;; vector we can point foreign code to.