From: David Lichteblau Date: Fri, 9 Nov 2012 13:54:19 +0000 (+0100) Subject: Add STDCALL alien convention support for Windows X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=79721a8731b8582ad8df664c2c4e04bd3d6090c6;p=sbcl.git 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 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -1137,27 +1137,68 @@ ;;;; 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 --- 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 --- 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.