X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fc-call.lisp;h=807e547de75b03ae4a41c547973d70ab0f552898;hb=127fd3d2fb843c6bb7ad0763e143d81877e760e8;hp=b2e4fc3e0443d9448e8b514a02b1697fa78a53ba;hpb=de01f09401517c1a96de3faeac585e46895940ec;p=sbcl.git diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp index b2e4fc3..807e547 100644 --- a/src/compiler/x86-64/c-call.lisp +++ b/src/compiler/x86-64/c-call.lisp @@ -150,6 +150,10 @@ (lambda-vars arg) (cond ((and (alien-integer-type-p type) (> (sb!alien::alien-integer-type-bits type) 64)) + ;; CLH: FIXME! This should really be + ;; #xffffffffffffffff. nyef says: "Passing + ;; 128-bit integers to ALIEN functions on x86-64 + ;; believed to be broken." (new-args `(logand ,arg #xffffffff)) (new-args `(ash ,arg -64)) (new-arg-types (parse-alien-type '(unsigned 64) env)) @@ -190,16 +194,16 @@ ;;; The ABI specifies that signed short/int's are returned as 32-bit ;;; values. Negative values need to be sign-extended to 64-bits (done ;;; in a :NATURALIZE-GEN alien-type-method). -(defknown sign-extend ((signed-byte 64)) (signed-byte 64) +(defknown sign-extend ((signed-byte 32)) fixnum (foldable flushable movable)) (define-vop (sign-extend) (:translate sign-extend) (:policy :fast-safe) (:args (val :scs (signed-reg))) - (:arg-types signed-byte-64) + (:arg-types fixnum) (:results (res :scs (signed-reg))) - (:result-types signed-byte-64) + (:result-types fixnum) (:generator 1 (inst movsxd res (make-random-tn :kind :normal @@ -207,9 +211,8 @@ :offset (tn-offset val))))) (defun sign-extend (x) - (if (logbitp 31 x) - (dpb x (byte 32 0) -1) - (ldb (byte 32 0) x))) + (declare (type (signed-byte 32) x)) + (sign-extend x)) (define-vop (foreign-symbol-sap) (:translate foreign-symbol-sap) @@ -243,6 +246,8 @@ (:vop-var vop) (:save-p t) (:generator 0 + ;; ABI: Direction flag must be clear on function entry. -- JES, 2006-01-20 + (inst cld) ;; ABI: AL contains amount of arguments passed in XMM registers ;; for vararg calls. (move-immediate rax @@ -263,7 +268,7 @@ (let ((delta (logandc2 (+ amount 7) 7))) (inst sub rsp-tn delta))) ;; C stack must be 16 byte aligned - (inst and rsp-tn #xfffffff0) + (inst and rsp-tn -16) (move result rsp-tn))) (define-vop (dealloc-number-stack-space) @@ -377,7 +382,10 @@ (rsp rsp-tn) (xmm0 float0-tn) ([rsp] (make-ea :qword :base rsp :disp 0)) - (words-processed 0) + ;; How many arguments have been copied + (arg-count 0) + ;; How many arguments have been copied from the stack + (stack-argument-count 0) (gprs (mapcar (make-tn-maker 'any-reg) *c-call-register-arg-offsets*)) (fprs (mapcar (make-tn-maker 'double-reg) ;; Only 8 first XMM registers are used for @@ -389,26 +397,57 @@ ;; Copy arguments from registers to stack (dolist (type argument-types) (let ((integerp (not (alien-float-type-p type))) - (stack-tn (make-ea :qword :base rsp - :disp (* words-processed - n-word-bytes)))) - (incf words-processed) + ;; A TN pointing to the stack location where the + ;; current argument should be stored for the purposes + ;; of ENTER-ALIEN-CALLBACK. + (target-tn (make-ea :qword :base rsp + :disp (* arg-count + n-word-bytes))) + ;; A TN pointing to the stack location that contains + ;; the next argument passed on the stack. + (stack-arg-tn (make-ea :qword :base rsp + :disp (* (+ 1 + (length argument-types) + stack-argument-count) + n-word-bytes)))) + (incf arg-count) (cond (integerp (let ((gpr (pop gprs))) - (if gpr - (inst mov stack-tn gpr) - (out-of-registers-error)))) + ;; Argument not in register, copy it from the old + ;; stack location to a temporary register. + (unless gpr + (incf stack-argument-count) + (setf gpr temp-reg-tn) + (inst mov gpr stack-arg-tn)) + ;; Copy from either argument register or temporary + ;; register to target. + (inst mov target-tn gpr))) ((or (alien-single-float-type-p type) (alien-double-float-type-p type)) (let ((fpr (pop fprs))) - (if fpr - (inst movq stack-tn fpr) - (out-of-registers-error)))) + (cond (fpr + ;; Copy from float register to target location. + (inst movq target-tn fpr)) + (t + ;; Not in float register. Copy from stack to + ;; temporary (general purpose) register, and + ;; from there to the target location. + (incf stack-argument-count) + (inst mov temp-reg-tn stack-arg-tn) + (inst mov target-tn temp-reg-tn))))) (t (bug "Unknown alien floating point type: ~S" type))))) ;; arg0 to FUNCALL3 (function) - (inst mov rdi (get-lisp-obj-address #'enter-alien-callback)) + ;; + ;; 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 expect anyone + ;; to rebind the variable. -- JES, 2006-01-01 + (inst mov rdi (+ nil-value (static-symbol-offset + 'sb!alien::*enter-alien-callback*))) + (loadw rdi rdi symbol-value-slot other-pointer-lowtag) ;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index) (inst mov rsi (fixnumize index)) ;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)