From: Christophe Rhodes Date: Mon, 16 Jan 2006 14:45:46 +0000 (+0000) Subject: 0.9.8.40: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=471a5d32673a4c0db86949424d624e6ea3a6a633;p=sbcl.git 0.9.8.40: Merge patch from Luis Oliveira "stdcall support for alien-funcall" sbcl-devel 2006-01-12 ... factor set-fpu-word-for-{c,lisp} out from number-stack-space manipulating vops. ... magic to adjust for calling convention. --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 9739983..350c7f4 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -43,7 +43,6 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "UNION" "VALUES" "*") :export ("ADDR" "ALIEN" - #!+win32 "ALIEN-FUNCALL-STDCALL" "ALIEN-FUNCALL" "ALIEN-SAP" "ALIEN-SIZE" "CAST" "C-STRING" "DEFINE-ALIEN-ROUTINE" "DEFINE-ALIEN-TYPE" "DEFINE-ALIEN-VARIABLE" @@ -197,7 +196,6 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "SB!KERNEL" "SB!SYS") :reexport ("SLOT" "CODE-INSTRUCTIONS" "FLUSHABLE") :export ("%ALIEN-FUNCALL" - #!+win32 "%ALIEN-FUNCALL-STDCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "%LISTIFY-REST-ARGS" "%MORE-ARG" "%MORE-ARG-VALUES" "%UNWIND-PROTECT-BREAKUP" @@ -218,6 +216,8 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "*SETF-ASSUMED-FBOUNDP*" "*SUPPRESS-VALUES-DECLARATION*" + #!+x86 "SET-FPU-WORD-FOR-C" + #!+x86 "SET-FPU-WORD-FOR-LISP" "ALLOC-ALIEN-STACK-SPACE" "ALLOC-NUMBER-STACK-SPACE" "ALLOCATE-CODE-OBJECT" "ALLOCATE-FRAME" "ALLOCATE-DYNAMIC-CODE-OBJECT" "ALLOCATE-FULL-CALL-FRAME" diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index ff7e49c..8a33628 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -587,37 +587,6 @@ (t (error "~S is not an alien function." alien))))) -(defun alien-funcall-stdcall (alien &rest args) - #!+sb-doc - "Call the foreign function ALIEN with the specified arguments. ALIEN's - type specifies the argument and result types." - (declare (type alien-value alien)) - (let ((type (alien-value-type alien))) - (typecase type - (alien-pointer-type - (apply #'alien-funcall-stdcall (deref alien) args)) - (alien-fun-type - (unless (= (length (alien-fun-type-arg-types type)) - (length args)) - (error "wrong number of arguments for ~S~%expected ~W, got ~W" - type - (length (alien-fun-type-arg-types type)) - (length args))) - (let ((stub (alien-fun-type-stub type))) - (unless stub - (setf stub - (let ((fun (gensym)) - (parms (make-gensym-list (length args)))) - (compile nil - `(lambda (,fun ,@parms) - (declare (optimize (sb!c::insert-step-conditions 0))) - (declare (type (alien ,type) ,fun)) - (alien-funcall-stdcall ,fun ,@parms))))) - (setf (alien-fun-type-stub type) stub)) - (apply stub alien args))) - (t - (error "~S is not an alien function." alien))))) - (defmacro define-alien-routine (name result-type &rest args &environment lexenv) diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 08f7100..7b19ac5 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -68,9 +68,6 @@ (defknown alien-funcall (alien-value &rest *) * (any recursive)) -#!+win32 -(defknown alien-funcall-stdcall (alien-value &rest *) * - (any recursive)) ;;;; cosmetic transforms @@ -667,15 +664,22 @@ (dolist (arg args) (annotate-ordinary-lvar arg))) +;;; We support both the stdcall and cdecl calling conventions on win32 by +;;; resetting ESP after the foreign function returns. This way it works +;;; correctly whether the party that is supposed to pop arguments from +;;; the stack is the caller (cdecl) or the callee (stdcall). (defoptimizer (%alien-funcall ir2-convert) ((function type &rest args) call block) (let ((type (if (constant-lvar-p type) (lvar-value type) (error "Something is broken."))) (lvar (node-lvar call)) - (args args)) + (args args) + #!+win32 (stack-pointer (make-stack-pointer-tn))) (multiple-value-bind (nsp stack-frame-size arg-tns result-tns) (make-call-out-tns type) + #!+x86 (vop set-fpu-word-for-c call block) + #!+win32 (vop current-stack-pointer call block stack-pointer) (vop alloc-number-stack-space call block stack-frame-size nsp) (dolist (tn arg-tns) ;; On PPC, TN might be a list. This is used to indicate @@ -730,124 +734,7 @@ ((lvar-tn call block function) (reference-tn-list arg-tns nil)) ((reference-tn-list result-tns t)))) - (vop dealloc-number-stack-space call block stack-frame-size) - (move-lvar-result call block result-tns lvar)))) - -;;;; ALIEN-FUNCALL-STDCALL support - -#!+win32 -(deftransform alien-funcall-stdcall ((function &rest args) - ((alien (* t)) &rest *) * - :important t) - (let ((names (make-gensym-list (length args)))) - (/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL-STDCALL" function args) - `(lambda (function ,@names) - (alien-funcall-stdcall (deref function) ,@names)))) - -#!+win32 -(deftransform alien-funcall-stdcall ((function &rest args) * * :important t) - (let ((type (lvar-type function))) - (unless (alien-type-type-p type) - (give-up-ir1-transform "can't tell function type at compile time")) - (/noshow "entering second DEFTRANSFORM ALIEN-FUNCALL-STDCALL" function) - (let ((alien-type (alien-type-type-alien-type type))) - (unless (alien-fun-type-p alien-type) - (give-up-ir1-transform)) - (let ((arg-types (alien-fun-type-arg-types alien-type))) - (unless (= (length args) (length arg-types)) - (abort-ir1-transform - "wrong number of arguments; expected ~W, got ~W" - (length arg-types) - (length args))) - (collect ((params) (deports)) - (dolist (arg-type arg-types) - (let ((param (gensym))) - (params param) - (deports `(deport ,param ',arg-type)))) - (let ((return-type (alien-fun-type-result-type alien-type)) - (body `(%alien-funcall-stdcall (deport function ',alien-type) - ',alien-type - ,@(deports)))) - (if (alien-values-type-p return-type) - (collect ((temps) (results)) - (dolist (type (alien-values-type-values return-type)) - (let ((temp (gensym))) - (temps temp) - (results `(naturalize ,temp ',type)))) - (setf body - `(multiple-value-bind ,(temps) ,body - (values ,@(results))))) - (setf body `(naturalize ,body ',return-type))) - (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL-STDCALL" (params) body) - `(lambda (function ,@(params)) - ,body))))))) - -#!+win32 -(defoptimizer (%alien-funcall-stdcall derive-type) ((function type &rest args)) - (declare (ignore function args)) - (unless (constant-lvar-p type) - (error "Something is broken.")) - (let ((type (lvar-value type))) - (unless (alien-fun-type-p type) - (error "Something is broken.")) - (values-specifier-type - (compute-alien-rep-type - (alien-fun-type-result-type type))))) - -#!+win32 -(defoptimizer (%alien-funcall-stdcall ltn-annotate) - ((function type &rest args) node ltn-policy) - (setf (basic-combination-info node) :funny) - (setf (node-tail-p node) nil) - (annotate-ordinary-lvar function) - (dolist (arg args) - (annotate-ordinary-lvar arg))) - -#!+win32 -(defoptimizer (%alien-funcall-stdcall ir2-convert) - ((function type &rest args) call block) - (let ((type (if (constant-lvar-p type) - (lvar-value type) - (error "Something is broken."))) - (lvar (node-lvar call)) - (args args)) - (multiple-value-bind (nsp stack-frame-size arg-tns result-tns) - (make-call-out-tns type) - (vop alloc-number-stack-space call block stack-frame-size nsp) - (dolist (tn arg-tns) - (let* ((arg (pop args)) - (sc (tn-sc tn)) - (scn (sc-number sc)) - #!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn) - scn)) - (move-arg-vops (svref (sc-move-arg-vops sc) scn))) - (aver arg) - (unless (= (length move-arg-vops) 1) - (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc))) - #!+x86 (emit-move-arg-template call - block - (first move-arg-vops) - (lvar-tn call block arg) - nsp - tn) - #!-x86 (progn - (emit-move call - block - (lvar-tn call block arg) - temp-tn) - (emit-move-arg-template call - block - (first move-arg-vops) - temp-tn - nsp - tn)))) - (aver (null args)) - (unless (listp result-tns) - (setf result-tns (list result-tns))) - (vop* call-out call block - ((lvar-tn call block function) - (reference-tn-list arg-tns nil)) - ((reference-tn-list result-tns t))) - ;; This is the stdcall magic: Callee clears args. - #+nil (vop dealloc-number-stack-space call block stack-frame-size) + #!-win32 (vop dealloc-number-stack-space call block stack-frame-size) + #!+win32 (vop reset-stack-pointer call block stack-pointer) + #!+x86 (vop set-fpu-word-for-lisp call block) (move-lvar-result call block result-tns lvar)))) diff --git a/src/compiler/early-aliencomp.lisp b/src/compiler/early-aliencomp.lisp index 0e5ad07..d19ce05 100644 --- a/src/compiler/early-aliencomp.lisp +++ b/src/compiler/early-aliencomp.lisp @@ -1,4 +1,3 @@ (in-package "SB!C") (defknown %alien-funcall (system-area-pointer alien-type &rest *) *) -(defknown %alien-funcall-stdcall (system-area-pointer alien-type &rest *) *) diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 4bcfd03..38a8fe2 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -181,63 +181,6 @@ ,@(new-args)))))) (sb!c::give-up-ir1-transform)))) -#!+win32 -(deftransform %alien-funcall-stdcall ((function type &rest args) * * :node node) - (aver (sb!c::constant-lvar-p type)) - (let* ((type (sb!c::lvar-value type)) - (env (sb!c::node-lexenv node)) - (arg-types (alien-fun-type-arg-types type)) - (result-type (alien-fun-type-result-type type))) - (aver (= (length arg-types) (length args))) - (if (or (some #'(lambda (type) - (and (alien-integer-type-p type) - (> (sb!alien::alien-integer-type-bits type) 32))) - arg-types) - (and (alien-integer-type-p result-type) - (> (sb!alien::alien-integer-type-bits result-type) 32))) - (collect ((new-args) (lambda-vars) (new-arg-types)) - (dolist (type arg-types) - (let ((arg (gensym))) - (lambda-vars arg) - (cond ((and (alien-integer-type-p type) - (> (sb!alien::alien-integer-type-bits type) 32)) - (new-args `(logand ,arg #xffffffff)) - (new-args `(ash ,arg -32)) - (new-arg-types (parse-alien-type '(unsigned 32) env)) - (if (alien-integer-type-signed type) - (new-arg-types (parse-alien-type '(signed 32) env)) - (new-arg-types (parse-alien-type '(unsigned 32) env)))) - (t - (new-args arg) - (new-arg-types type))))) - (cond ((and (alien-integer-type-p result-type) - (> (sb!alien::alien-integer-type-bits result-type) 32)) - (let ((new-result-type - (let ((sb!alien::*values-type-okay* t)) - (parse-alien-type - (if (alien-integer-type-signed result-type) - '(values (unsigned 32) (signed 32)) - '(values (unsigned 32) (unsigned 32))) - env)))) - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (multiple-value-bind (low high) - (%alien-funcall function - ',(make-alien-fun-type - :arg-types (new-arg-types) - :result-type new-result-type) - ,@(new-args)) - (logior low (ash high 32)))))) - (t - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (%alien-funcall function - ',(make-alien-fun-type - :arg-types (new-arg-types) - :result-type result-type) - ,@(new-args)))))) - (sb!c::give-up-ir1-transform)))) - (define-vop (foreign-symbol-sap) (:translate foreign-symbol-sap) (:policy :fast-safe) @@ -302,31 +245,24 @@ (inst fldz)) ; insure no regs are empty )))) -(define-vop (alloc-number-stack-space) - (:info amount) - (:results (result :scs (sap-reg any-reg))) +;;; While SBCL uses the FPU in 53-bit mode, most C libraries assume that +;;; the FPU is in 64-bit mode. So we change the FPU mode to 64-bit with +;;; the SET-FPU-WORD-FOR-C VOP before calling out to C and set it back +;;; to 53-bit mode after coming back using the SET-FPU-WORD-FOR-LISP VOP. +(define-vop (set-fpu-word-for-c) (:node-var node) (:generator 0 - (aver (location= result esp-tn)) (when (policy node (= sb!c::float-accuracy 3)) (inst sub esp-tn 4) (inst fnstcw (make-ea :word :base esp-tn)) (inst wait) (inst or (make-ea :word :base esp-tn) #x300) (inst fldcw (make-ea :word :base esp-tn)) - (inst wait)) - (unless (zerop amount) - (let ((delta (logandc2 (+ amount 3) 3))) - (inst sub esp-tn delta))) - (move result esp-tn))) + (inst wait)))) -(define-vop (dealloc-number-stack-space) - (:info amount) +(define-vop (set-fpu-word-for-lisp) (:node-var node) (:generator 0 - (unless (zerop amount) - (let ((delta (logandc2 (+ amount 3) 3))) - (inst add esp-tn delta))) (when (policy node (= sb!c::float-accuracy 3)) (inst fnstcw (make-ea :word :base esp-tn)) (inst wait) @@ -335,6 +271,23 @@ (inst wait) (inst add esp-tn 4)))) +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:generator 0 + (aver (location= result esp-tn)) + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst sub esp-tn delta))) + (move result esp-tn))) + +(define-vop (dealloc-number-stack-space) + (:info amount) + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst add esp-tn delta))))) + (define-vop (alloc-alien-stack-space) (:info amount) #!+sb-thread (:temporary (:sc unsigned-reg) temp) diff --git a/version.lisp-expr b/version.lisp-expr index fab6341..edfbde1 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.8.39" +"0.9.8.40"