X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fc-call.lisp;h=2fa84d07f24a04a241ea206fbe48e9f9482a092f;hb=3fe0010d2777b41e01ea9b4a0f894cfa40f7df1b;hp=c41a0ce312c4863c80ef5a5729c0cb4e5de0aac4;hpb=095a47764e687fa76cf0e2803633d30c65c00f40;p=sbcl.git diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp index c41a0ce..2fa84d0 100644 --- a/src/compiler/x86-64/c-call.lisp +++ b/src/compiler/x86-64/c-call.lisp @@ -81,13 +81,16 @@ (setf (result-state-num-results state) (1+ num-results)) (multiple-value-bind (ptype reg-sc) (if (alien-integer-type-signed type) - (values (if (= (sb!alien::alien-integer-type-bits type) 32) - 'signed-byte-32 - 'signed-byte-64) - 'signed-reg) + (values 'signed-byte-64 'signed-reg) (values 'unsigned-byte-64 'unsigned-reg)) (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) + alien)) + (define-alien-type-method (system-area-pointer :result-tn) (type state) (declare (ignore type)) (let ((num-results (result-state-num-results state))) @@ -184,11 +187,31 @@ ,@(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)) - - -(define-vop (foreign-symbol-address) - (:translate foreign-symbol-address) +(define-vop (sign-extend) + (:translate sign-extend) + (:policy :fast-safe) + (:args (val :scs (any-reg))) + (:arg-types fixnum) + (:results (res :scs (any-reg))) + (:result-types fixnum) + (:generator 1 + (inst movsxd res + (make-random-tn :kind :normal + :sc (sc-or-lose '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))) + +(define-vop (foreign-symbol-sap) + (:translate foreign-symbol-sap) (:policy :fast-safe) (:args) (:arg-types (:constant simple-string)) @@ -196,11 +219,11 @@ (:results (res :scs (sap-reg))) (:result-types system-area-pointer) (:generator 2 - (inst lea res (make-fixup (extern-alien-name foreign-symbol) :foreign)))) + (inst lea res (make-fixup foreign-symbol :foreign)))) #!+linkage-table -(define-vop (foreign-symbol-dataref-address) - (:translate foreign-symbol-dataref-address) +(define-vop (foreign-symbol-dataref-sap) + (:translate foreign-symbol-dataref-sap) (:policy :fast-safe) (:args) (:arg-types (:constant simple-string)) @@ -208,15 +231,14 @@ (:results (res :scs (sap-reg))) (:result-types system-area-pointer) (:generator 2 - (inst mov res (make-fixup (extern-alien-name foreign-symbol) :foreign-dataref)))) + (inst mov res (make-fixup foreign-symbol :foreign-dataref)))) (define-vop (call-out) (:args (function :scs (sap-reg)) (args :more t)) (:results (results :more t)) (:temporary (:sc unsigned-reg :offset rax-offset :to :result) rax) - (:temporary (:sc unsigned-reg :offset rcx-offset - :from :eval :to :result) rcx) + (:ignore results) (:vop-var vop) (:save-p t) (:generator 0 @@ -230,22 +252,11 @@ (inst call function) ;; To give the debugger a clue. XX not really internal-error? (note-this-location vop :internal-error) - ;; Sign-extend s-b-32 return values. - (dolist (res (if (listp results) - results - (list results))) - (let ((tn (tn-ref-tn res))) - (when (eq (sb!c::tn-primitive-type tn) - (primitive-type-or-lose 'signed-byte-32)) - (inst movsxd tn (make-random-tn :kind :normal - :sc (sc-or-lose 'dword-reg) - :offset (tn-offset tn)))))) ;; FLOAT15 needs to contain FP zero in Lispland - (inst xor rcx rcx) - (inst movd (make-random-tn :kind :normal + (let ((float15 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) - :offset float15-offset) - rcx))) + :offset float15-offset))) + (inst xorpd float15 float15)))) (define-vop (alloc-number-stack-space) (:info amount) @@ -253,15 +264,17 @@ (:generator 0 (aver (location= result rsp-tn)) (unless (zerop amount) - (let ((delta (logandc2 (+ amount 3) 3))) + (let ((delta (logandc2 (+ amount 7) 7))) (inst sub rsp-tn delta))) + ;; C stack must be 16 byte aligned + (inst and rsp-tn #xfffffff0) (move result rsp-tn))) (define-vop (dealloc-number-stack-space) (:info amount) (:generator 0 (unless (zerop amount) - (let ((delta (logandc2 (+ amount 3) 3))) + (let ((delta (logandc2 (+ amount 7) 7))) (inst add rsp-tn delta))))) (define-vop (alloc-alien-stack-space) @@ -272,21 +285,21 @@ (:generator 0 (aver (not (location= result rsp-tn))) (unless (zerop amount) - (let ((delta (logandc2 (+ amount 3) 3))) + (let ((delta (logandc2 (+ amount 7) 7))) (inst mov temp - (make-ea :dword + (make-ea :qword :disp (+ nil-value (static-symbol-offset '*alien-stack*) (ash symbol-tls-index-slot word-shift) (- other-pointer-lowtag)))) - (inst fs-segment-prefix) - (inst sub (make-ea :dword :scale 1 :index temp) delta))) + (inst sub (make-ea :qword :base thread-base-tn + :scale 1 :index temp) delta))) (load-tl-symbol-value result *alien-stack*)) #!-sb-thread (:generator 0 (aver (not (location= result rsp-tn))) (unless (zerop amount) - (let ((delta (logandc2 (+ amount 3) 3))) + (let ((delta (logandc2 (+ amount 7) 7))) (inst sub (make-ea :qword :disp (+ nil-value (static-symbol-offset '*alien-stack*) @@ -301,19 +314,19 @@ #!+sb-thread (:generator 0 (unless (zerop amount) - (let ((delta (logandc2 (+ amount 3) 3))) + (let ((delta (logandc2 (+ amount 7) 7))) (inst mov temp - (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) + (make-ea :qword + :disp (+ nil-value + (static-symbol-offset '*alien-stack*) (ash symbol-tls-index-slot word-shift) (- other-pointer-lowtag)))) - (inst fs-segment-prefix) - (inst add (make-ea :dword :scale 1 :index temp) delta)))) + (inst add (make-ea :qword :base thread-base-tn :scale 1 :index temp) + delta)))) #!-sb-thread (:generator 0 (unless (zerop amount) - (let ((delta (logandc2 (+ amount 3) 3))) + (let ((delta (logandc2 (+ amount 7) 7))) (inst add (make-ea :qword :disp (+ nil-value (static-symbol-offset '*alien-stack*)