X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fc-call.lisp;h=ede3845d41b6d827623666a70d3dbc9ab7530d03;hb=91a5cbf7375439309fede4776d8debc7a132dc20;hp=1ab967a746f25d31b7a8a08345c018c309456dec;hpb=b4a85c101536166d4b6521d3a28d5cef5937dc6b;p=sbcl.git diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp index 1ab967a..ede3845 100644 --- a/src/compiler/x86-64/c-call.lisp +++ b/src/compiler/x86-64/c-call.lisp @@ -27,9 +27,13 @@ (xmm-args 0) (stack-frame-size 0)) +(defconstant max-int-args #.(length *c-call-register-arg-offsets*)) +(defconstant max-xmm-args #!+win32 4 #!-win32 8) + (defun int-arg (state prim-type reg-sc stack-sc) - (let ((reg-args (arg-state-register-args state))) - (cond ((< reg-args 6) + (let ((reg-args (max (arg-state-register-args state) + #!+win32 (arg-state-xmm-args state)))) + (cond ((< reg-args max-int-args) (setf (arg-state-register-args state) (1+ reg-args)) (my-make-wired-tn prim-type reg-sc (nth reg-args *c-call-register-arg-offsets*))) @@ -48,8 +52,9 @@ (int-arg state 'system-area-pointer 'sap-reg 'sap-stack)) (defun float-arg (state prim-type reg-sc stack-sc) - (let ((xmm-args (arg-state-xmm-args state))) - (cond ((< xmm-args 8) + (let ((xmm-args (max (arg-state-xmm-args state) + #!+win32 (arg-state-register-args state)))) + (cond ((< xmm-args max-xmm-args) (setf (arg-state-xmm-args state) (1+ xmm-args)) (my-make-wired-tn prim-type reg-sc (nth xmm-args *float-regs*))) @@ -74,8 +79,6 @@ (0 eax-offset) (1 edx-offset))) -;; XXX The return handling probably doesn't conform to the ABI - (define-alien-type-method (integer :result-tn) (type state) (let ((num-results (result-state-num-results state))) (setf (result-state-num-results state) (1+ num-results)) @@ -86,9 +89,10 @@ (my-make-wired-tn ptype reg-sc (result-reg-offset num-results))))) (define-alien-type-method (integer :naturalize-gen) (type alien) - (if (and (alien-integer-type-signed type) - (<= (alien-type-bits type) 32)) - `(sign-extend ,alien) + (if (<= (alien-type-bits type) 32) + (if (alien-integer-type-signed type) + `(sign-extend ,alien ,(alien-type-bits type)) + `(logand ,alien ,(1- (ash 1 (alien-type-bits type))))) alien)) (define-alien-type-method (system-area-pointer :result-tn) (type state) @@ -118,7 +122,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)) @@ -150,6 +154,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)) @@ -187,28 +195,44 @@ ,@(new-args)))))) (sb!c::give-up-ir1-transform)))) -;;; 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 (fixnum) fixnum (foldable flushable movable)) +;;; The ABI is vague about how signed sub-word integer return values +;;; are handled, but since gcc versions >=4.3 no longer do sign +;;; extension in the callee, we need to do it in the caller. FIXME: +;;; If the value to be extended is known to already be of the target +;;; type at compile time, we can (and should) elide the extension. +(defknown sign-extend ((signed-byte 64) t) fixnum + (foldable flushable movable)) (define-vop (sign-extend) (:translate sign-extend) (:policy :fast-safe) - (:args (val :scs (any-reg))) - (:arg-types fixnum) - (:results (res :scs (any-reg))) + (:args (val :scs (signed-reg))) + (:arg-types signed-num (:constant fixnum)) + (:info size) + (:results (res :scs (signed-reg))) (:result-types fixnum) (:generator 1 (inst movsxd res (make-random-tn :kind :normal - :sc (sc-or-lose 'dword-reg) + :sc (sc-or-lose (ecase size + (8 'byte-reg) + (16 'word-reg) + (32 'dword-reg))) :offset (tn-offset val))))) -(defun sign-extend (x) - (if (logbitp 31 x) - (dpb x (byte 32 0) -1) - (ldb (byte 32 0) x))) +#-sb-xc-host +(defun sign-extend (x size) + (declare (type (signed-byte 64) x)) + (ecase size + (8 (sign-extend x size)) + (16 (sign-extend x size)) + (32 (sign-extend x size)))) + +#+sb-xc-host +(defun sign-extend (x size) + (if (logbitp (1- size) x) + (dpb x (byte size 0) -1) + x)) (define-vop (foreign-symbol-sap) (:translate foreign-symbol-sap) @@ -238,10 +262,40 @@ (args :more t)) (:results (results :more t)) (:temporary (:sc unsigned-reg :offset rax-offset :to :result) rax) - (:ignore results) + ;; For safepoint builds: Force values of non-volatiles to the stack. + ;; These are the callee-saved registers in the native ABI, but + ;; safepoint-based GC needs to see all Lisp values on the stack. Note + ;; that R12-R15 are non-volatile registers, but there is no need to + ;; spill R12 because it is our thread-base-tn. RDI and RSI are + ;; non-volatile on Windows, but argument passing registers on other + ;; platforms. + #!+sb-safepoint (:temporary (:sc unsigned-reg :offset r13-offset) r13) + #!+sb-safepoint (:temporary (:sc unsigned-reg :offset r14-offset) r14) + #!+sb-safepoint (:temporary (:sc unsigned-reg :offset r15-offset) r15) + #!+(and sb-safepoint win32) (:temporary + (:sc unsigned-reg :offset rdi-offset) rdi) + #!+(and sb-safepoint win32) (:temporary + (:sc unsigned-reg :offset rsi-offset) rsi) + (:ignore results + #!+(and sb-safepoint win32) rdi + #!+(and sb-safepoint win32) rsi + #!+win32 args + #!+win32 rax + #!+sb-safepoint r15 + #!+sb-safepoint r13) (:vop-var vop) (:save-p t) (:generator 0 + ;; ABI: Direction flag must be clear on function entry. -- JES, 2006-01-20 + (inst cld) + #!+sb-safepoint + (progn + ;; Current PC - don't rely on function to keep it in a form that + ;; GC understands + (let ((label (gen-label))) + (inst lea r14 (make-fixup nil :code-object label)) + (emit-label label))) + #!-win32 ;; ABI: AL contains amount of arguments passed in XMM registers ;; for vararg calls. (move-immediate rax @@ -249,25 +303,35 @@ while tn-ref count (eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref)))) 'float-registers))) + #!+win32 (inst sub rsp-tn #x20) ;MS_ABI: shadow zone + #!+sb-safepoint + (progn ;Store SP and PC in thread struct + (storew rsp-tn thread-base-tn thread-saved-csp-offset) + (storew r14 thread-base-tn thread-pc-around-foreign-call-slot)) (inst call function) + #!+win32 (inst add rsp-tn #x20) ;MS_ABI: remove shadow space + #!+sb-safepoint + (progn + ;; Zeroing out + (inst xor r14 r14) + ;; Zero PC storage place. NB. CSP-then-PC: same sequence on + ;; entry/exit, is actually corrent. + (storew r14 thread-base-tn thread-saved-csp-offset) + (storew r14 thread-base-tn thread-pc-around-foreign-call-slot)) ;; To give the debugger a clue. XX not really internal-error? - (note-this-location vop :internal-error) - ;; FLOAT15 needs to contain FP zero in Lispland - (let ((float15 (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset float15-offset))) - (inst xorpd float15 float15)))) + (note-this-location vop :internal-error))) (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 rsp-tn)) (unless (zerop amount) (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) @@ -281,6 +345,7 @@ (: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 rsp-tn))) @@ -334,27 +399,16 @@ (- other-pointer-lowtag))) 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 60))) - (:info number) - (:policy :fast-safe) - (:generator 2 - (inst add rsp-tn (fixnumize number)))) + (:arg-types t) + (:generator 0)) ;;; Callbacks @@ -373,66 +427,127 @@ (error "Too many arguments in callback"))) (let* ((segment (make-segment)) (rax rax-tn) - (rcx rcx-tn) - (rdi rdi-tn) - (rsi rsi-tn) + #!+(or win32 (not sb-safepoint)) (rcx rcx-tn) + #!-win32 (rdi rdi-tn) + #!-win32 (rsi rsi-tn) (rdx rdx-tn) (rbp rbp-tn) (rsp rsp-tn) + #!+win32 (r8 r8-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 #!-win32 0 #!+win32 4) (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 ;; passing arguments - (subseq *float-regs* 0 8)))) + (subseq *float-regs* 0 #!-win32 8 #!+win32 4)))) (assemble (segment) ;; Make room on the stack for arguments. (inst sub rsp (* n-word-bytes (length argument-types))) ;; 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)))) + #!+win32 (pop fprs) + ;; 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)))) + #!+win32 (pop gprs) + (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)) - ;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index) - (inst mov rsi (fixnumize index)) - ;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector) - (inst mov rdx rsp) - ;; add room on stack for return value - (inst sub rsp 8) - ;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value) - (inst mov rcx rsp) - - ;; Make new frame - (inst push rbp) - (inst mov rbp rsp) - - ;; Call - (inst mov rax (foreign-symbol-address "funcall3")) - (inst call rax) - - ;; Back! Restore frame - (inst mov rsp rbp) - (inst pop rbp) + #!-sb-safepoint + (progn + ;; arg0 to FUNCALL3 (function) + ;; + ;; 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) + (inst mov rdx rsp) + ;; add room on stack for return value + (inst sub rsp 8) + ;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value) + (inst mov rcx rsp) + + ;; Make new frame + (inst push rbp) + (inst mov rbp rsp) + + ;; Call + (inst mov rax (foreign-symbol-address "funcall3")) + (inst call rax) + + ;; Back! Restore frame + (inst mov rsp rbp) + (inst pop rbp)) + + #!+sb-safepoint + (progn + ;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index) + (inst mov #!-win32 rdi #!+win32 rcx (fixnumize index)) + ;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector) + (inst mov #!-win32 rsi #!+win32 rdx rsp) + ;; add room on stack for return value + (inst sub rsp 8) + ;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value) + (inst mov #!-win32 rdx #!+win32 r8 rsp) + ;; Make new frame + (inst push rbp) + (inst mov rbp rsp) + #!+win32 (inst sub rsp #x20) + #!+win32 (inst and rsp #x-20) + ;; Call + (inst mov rax (foreign-symbol-address "callback_wrapper_trampoline")) + (inst call rax) + ;; Back! Restore frame + (inst mov rsp rbp) + (inst pop rbp)) ;; Result now on top of stack, put it in the right register (cond