X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fc-call.lisp;h=3c5ffae2224e0da51ba26c8374c7729d34b8bf72;hb=74cf7a4d01664fbf72a662ba093ad67ca243b524;hp=7eec4723a4838d0ed621ff8c3e5e9f552c570bd2;hpb=e7476d980c0b4949c9416b59249d0d621c0f747d;p=sbcl.git diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 7eec472..3c5ffae 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -119,7 +119,7 @@ (invoke-alien-type-method :result-tn type state)) values))) -(!def-vm-support-routine make-call-out-tns (type) +(defun make-call-out-tns (type) (let ((arg-state (make-arg-state))) (collect ((arg-tns)) (dolist (arg-type (alien-fun-type-arg-types type)) @@ -252,6 +252,21 @@ (:generator 2 (inst mov res (make-fixup foreign-symbol :foreign-dataref)))) +(defun force-x87-to-mem (tn fp-temp) + (aver (location= tn fr0-tn)) + (sc-case tn + (single-reg + (let ((ea (ea-for-sf-stack fp-temp))) + (inst fstp ea) + (inst fld ea))) + (double-reg + (let ((ea (ea-for-df-stack fp-temp))) + (inst fstpd ea) + (inst fldd ea))) + #!+long-float + (long-reg ; nothing to do! + ))) + (define-vop (call-out) (:args (function :scs (sap-reg)) (args :more t)) @@ -262,17 +277,30 @@ :from :eval :to :result) ecx) (:temporary (:sc unsigned-reg :offset edx-offset :from :eval :to :result) edx) - (:node-var node) + (:temporary (:sc double-stack) fp-temp) + #!+sb-safepoint (:temporary (:sc unsigned-reg :offset esi-offset) esi) + #!+sb-safepoint (:temporary (:sc unsigned-reg :offset edi-offset) edi) + #!-sb-safepoint (:node-var node) (:vop-var vop) (:save-p t) - (:ignore args ecx edx) + (:ignore args ecx edx + #!+sb-safepoint esi + #!+sb-safepoint edi) (: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)) + (cond ((and + ;; On safepoints builds, we currently use the out-of-line + ;; calling routine irrespectively of SPACE and SPEED policy. + ;; An inline version of said changes is left to the + ;; sufficiently motivated maintainer. + #!-sb-safepoint (policy node (> space speed))) (move eax function) - (inst call (make-fixup "call_into_c" :foreign))) + (inst call (make-fixup "call_into_c" :foreign)) + (when (and results + (location= (tn-ref-tn results) fr0-tn)) + (force-x87-to-mem (tn-ref-tn results) fp-temp))) (t ;; Setup the NPX for C; all the FP registers need to be ;; empty; pop them all. @@ -291,12 +319,13 @@ (dotimes (i 7) (inst fldz)) - (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 - )))) + (cond ((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 + (force-x87-to-mem (tn-ref-tn results) fp-temp)) + (t ; ensure no regs are empty + (inst fldz))))))) ;;; 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 @@ -346,9 +375,10 @@ (aver (not (location= result esp-tn))) (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst mov temp - (make-ea-for-symbol-tls-index *alien-stack*)) - (inst sub (make-ea :dword :base temp) delta :fs))) + (with-tls-ea (EA :base temp + :disp-type :index + :disp (make-ea-for-symbol-tls-index *alien-stack*)) + (inst sub EA delta :maybe-fs)))) (load-tl-symbol-value result *alien-stack*)) #!-sb-thread (:generator 0 @@ -366,9 +396,10 @@ (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst mov temp - (make-ea-for-symbol-tls-index *alien-stack*)) - (inst add (make-ea :dword :base temp) delta :fs)))) + (with-tls-ea (EA :base temp + :disp-type :index + :disp (make-ea-for-symbol-tls-index *alien-stack*)) + (inst add EA delta :maybe-fs))))) #!-sb-thread (:generator 0 (unless (zerop amount) @@ -392,7 +423,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)) @@ -413,15 +445,23 @@ pointer to the arguments." (inst push eax) ; arg1 (inst push (ash index 2)) ; arg0 - ;; Indirect the access to ENTER-ALIEN-CALLBACK through - ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK* - ;; 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 - (load-symbol-value eax sb!alien::*enter-alien-callback*) - (inst push eax) ; function - (inst mov eax (foreign-symbol-address "funcall3")) - (inst call eax) + #!+sb-safepoint + (progn + (inst mov eax (foreign-symbol-address "callback_wrapper_trampoline")) + (inst call eax)) + + #!-sb-safepoint + (progn + ;; Indirect the access to ENTER-ALIEN-CALLBACK through + ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK* + ;; 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 + (load-symbol-value eax sb!alien::*enter-alien-callback*) + (inst push eax) ; function + (inst mov eax (foreign-symbol-address "funcall3")) + (inst call eax)) + ;; now put the result into the right register (cond ((and (alien-integer-type-p return-type) @@ -442,7 +482,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.