X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fc-call.lisp;h=ae98e18dc36742ae30d94d26048357d483906e0d;hb=e119a2f79cf36039a39996f5490934b4d927529a;hp=4bcfd03a0bc70ef19ed00155710e3b89ee5d93bd;hpb=93be0089fe7b2a9e34bf1cb6da9fe6e902769f5e;p=sbcl.git diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 4bcfd03..ae98e18 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) @@ -276,6 +219,9 @@ (:save-p t) (:ignore args ecx edx) (:generator 0 + ;; FIXME & OAOOM: This is brittle and error-prone to maintain two + ;; instances of the same logic, on in arch-assem.S, and one in + ;; c-call.lisp. If you modify this, modify that one too... (cond ((policy node (> space speed)) (move eax function) (inst call (make-fixup "call_into_c" :foreign))) @@ -285,10 +231,12 @@ (dotimes (i 8) (inst fstp fr0-tn)) - #!+win32 (inst cld) + ;; Clear out DF: Darwin, Windows, and Solaris at least require + ;; this, and it should not hurt others either. + (inst cld) (inst call function) - ;; To give the debugger a clue. XX not really internal-error? + ;; To give the debugger a clue. FIXME: not really internal-error? (note-this-location vop :internal-error) ;; Restore the NPX for lisp; ensure no regs are empty @@ -298,35 +246,28 @@ (if (and results (location= (tn-ref-tn results) fr0-tn)) ;; The return result is in fr0. - (inst fxch fr7-tn) ; move the result back to fr0 - (inst fldz)) ; insure no regs are empty + (inst fxch fr7-tn) ; move the result back to fr0 + (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,34 +276,39 @@ (inst wait) (inst add esp-tn 4)))) +(define-vop (alloc-number-stack-space) + (:info amount) + (:results (result :scs (sap-reg any-reg))) + (:result-types system-area-pointer) + (:generator 0 + (aver (location= result esp-tn)) + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst sub esp-tn delta))) + (align-stack-pointer esp-tn) + (move result esp-tn))) + (define-vop (alloc-alien-stack-space) (:info amount) #!+sb-thread (:temporary (:sc unsigned-reg) temp) (:results (result :scs (sap-reg any-reg))) + (:result-types system-area-pointer) #!+sb-thread (:generator 0 (aver (not (location= result esp-tn))) (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) (inst mov temp - (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) - (ash symbol-tls-index-slot word-shift) - (- other-pointer-lowtag)))) + (make-ea-for-symbol-tls-index *alien-stack*)) (inst fs-segment-prefix) - (inst sub (make-ea :dword :scale 1 :index temp) delta))) + (inst sub (make-ea :dword :base temp) delta))) (load-tl-symbol-value result *alien-stack*)) #!-sb-thread (:generator 0 (aver (not (location= result esp-tn))) (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst sub (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) + (inst sub (make-ea-for-symbol-value *alien-stack*) delta))) (load-symbol-value result *alien-stack*))) @@ -374,45 +320,26 @@ (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) (inst mov temp - (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) - (ash symbol-tls-index-slot word-shift) - (- other-pointer-lowtag)))) + (make-ea-for-symbol-tls-index *alien-stack*)) (inst fs-segment-prefix) - (inst add (make-ea :dword :scale 1 :index temp) delta)))) + (inst add (make-ea :dword :base temp) delta)))) #!-sb-thread (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst add (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) + (inst add (make-ea-for-symbol-value *alien-stack*) delta))))) -;;; these are not strictly part of the c-call convention, but are -;;; needed for the WITH-PRESERVED-POINTERS macro used for "locking -;;; down" lisp objects so that GC won't move them while foreign -;;; functions go to work. - -(define-vop (push-word-on-c-stack) - (:translate push-word-on-c-stack) - (:args (val :scs (sap-reg))) +;;; not strictly part of the c-call convention, but needed for the +;;; WITH-PINNED-OBJECTS macro used for "locking down" lisp objects so +;;; that GC won't move them while foreign functions go to work. +(define-vop (touch-object) + (:translate touch-object) + (:args (object)) + (:ignore object) (:policy :fast-safe) - (:arg-types system-area-pointer) - (:generator 2 - (inst push val))) - -(define-vop (pop-words-from-c-stack) - (:translate pop-words-from-c-stack) - (:args) - (:arg-types (:constant (unsigned-byte 29))) - (:info number) - (:policy :fast-safe) - (:generator 2 - (inst add esp-tn (fixnumize number)))) + (:arg-types t) + (:generator 0)) #-sb-xc-host (defun alien-callback-accessor-form (type sp offset) @@ -445,9 +372,7 @@ pointer to the arguments." ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK. ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone ;; to rebind the variable. -- JES, 2006-01-01 - (inst mov eax (+ nil-value (static-symbol-offset - 'sb!alien::*enter-alien-callback*))) - (loadw eax eax symbol-value-slot other-pointer-lowtag) + (load-symbol-value eax sb!alien::*enter-alien-callback*) (inst push eax) ; function (inst mov eax (foreign-symbol-address "funcall3")) (inst call eax)