X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fcell.lisp;h=a5114eb7541b81d92a00eafe0f33d9bc65397686;hb=7deecae2d959173eda6a153d490c752c32050a9e;hp=2a02340276fd9b50bd5f8fba5fb727ff085bbede;hpb=c6538bf61955a67d0145aa3e6c937f6dd03f9e51;p=sbcl.git diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 2a02340..a5114eb 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -19,7 +19,7 @@ (:ignore name) (:results (result :scs (descriptor-reg any-reg))) (:generator 1 - (loadw result object offset lowtag))) + (loadw result object offset lowtag))) (define-vop (set-slot) (:args (object :scs (descriptor-reg)) @@ -59,11 +59,9 @@ (:results (result :scs (descriptor-reg any-reg))) (:generator 5 (move rax old) - #!+sb-thread - (inst lock) (inst cmpxchg (make-ea :qword :base object :disp (- (* offset n-word-bytes) lowtag)) - new) + new :lock) (move result rax))) ;;;; symbol hacking VOPs @@ -95,96 +93,28 @@ new) (inst cmp rax no-tls-value-marker-widetag) (inst jmp :ne check) - (move rax old) - (inst lock)) + (move rax old)) (inst cmpxchg (make-ea :qword :base symbol :disp (- (* symbol-value-slot n-word-bytes) other-pointer-lowtag) :scale 1) - new) + new :lock) (emit-label check) (move result rax) (inst cmp result unbound-marker-widetag) (inst jmp :e unbound)))) -;;; these next two cf the sparc version, by jrd. -;;; FIXME: Deref this ^ reference. - - -;;; The compiler likes to be able to directly SET symbols. -#!+sb-thread -(define-vop (set) - (:args (symbol :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) - (:temporary (:sc descriptor-reg) tls) - ;;(:policy :fast-safe) - (:generator 4 - (let ((global-val (gen-label)) - (done (gen-label))) - (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) - (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls) - no-tls-value-marker-widetag) - (inst jmp :z global-val) - (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls) - value) - (inst jmp done) - (emit-label global-val) - (storew value symbol symbol-value-slot other-pointer-lowtag) - (emit-label done)))) - -;; unithreaded it's a lot simpler ... -#!-sb-thread -(define-vop (set cell-set) +(define-vop (%set-symbol-global-value cell-set) (:variant symbol-value-slot other-pointer-lowtag)) -;;; With Symbol-Value, we check that the value isn't the trap object. So -;;; Symbol-Value of NIL is NIL. -#!+sb-thread -(define-vop (symbol-value) - (:translate symbol-value) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg) :to (:result 1))) - (:results (value :scs (descriptor-reg any-reg))) - (:vop-var vop) - (:save-p :compute-only) - (:generator 9 - (let* ((check-unbound-label (gen-label)) - (err-lab (generate-error-code vop 'unbound-symbol-error object)) - (ret-lab (gen-label))) - (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst mov value (make-ea :qword :base thread-base-tn - :index value :scale 1)) - (inst cmp value no-tls-value-marker-widetag) - (inst jmp :ne check-unbound-label) - (loadw value object symbol-value-slot other-pointer-lowtag) - (emit-label check-unbound-label) - (inst cmp value unbound-marker-widetag) - (inst jmp :e err-lab) - (emit-label ret-lab)))) - -#!+sb-thread -(define-vop (fast-symbol-value symbol-value) - ;; KLUDGE: not really fast, in fact, because we're going to have to - ;; do a full lookup of the thread-local area anyway. But half of - ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if - ;; unbound", which is used in the implementation of COPY-SYMBOL. -- - ;; CSR, 2003-04-22 +(define-vop (fast-symbol-global-value cell-ref) + (:variant symbol-value-slot other-pointer-lowtag) (:policy :fast) - (:translate symbol-value) - (:generator 8 - (let ((ret-lab (gen-label))) - (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst mov value - (make-ea :qword :base thread-base-tn :index value :scale 1)) - (inst cmp value no-tls-value-marker-widetag) - (inst jmp :ne ret-lab) - (loadw value object symbol-value-slot other-pointer-lowtag) - (emit-label ret-lab)))) + (:translate symbol-global-value)) -#!-sb-thread -(define-vop (symbol-value) - (:translate symbol-value) +(define-vop (symbol-global-value) (:policy :fast-safe) + (:translate symbol-global-value) (:args (object :scs (descriptor-reg) :to (:result 1))) (:results (value :scs (descriptor-reg any-reg))) (:vop-var vop) @@ -195,38 +125,82 @@ (inst cmp value unbound-marker-widetag) (inst jmp :e err-lab)))) -#!-sb-thread -(define-vop (fast-symbol-value cell-ref) - (:variant symbol-value-slot other-pointer-lowtag) - (:policy :fast) - (:translate symbol-value)) - -(defknown locked-symbol-global-value-add (symbol fixnum) fixnum ()) +#!+sb-thread +(progn + (define-vop (set) + (:args (symbol :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg) tls) + (:generator 4 + (let ((global-val (gen-label)) + (done (gen-label))) + (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) + (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls) + no-tls-value-marker-widetag) + (inst jmp :z global-val) + (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls) + value) + (inst jmp done) + (emit-label global-val) + (storew value symbol symbol-value-slot other-pointer-lowtag) + (emit-label done)))) + + ;; With Symbol-Value, we check that the value isn't the trap object. So + ;; Symbol-Value of NIL is NIL. + (define-vop (symbol-value) + (:translate symbol-value) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 9 + (let* ((check-unbound-label (gen-label)) + (err-lab (generate-error-code vop 'unbound-symbol-error object)) + (ret-lab (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst mov value (make-ea :qword :base thread-base-tn + :index value :scale 1)) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne check-unbound-label) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label check-unbound-label) + (inst cmp value unbound-marker-widetag) + (inst jmp :e err-lab) + (emit-label ret-lab)))) + + (define-vop (fast-symbol-value symbol-value) + ;; KLUDGE: not really fast, in fact, because we're going to have to + ;; do a full lookup of the thread-local area anyway. But half of + ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if + ;; unbound", which is used in the implementation of COPY-SYMBOL. -- + ;; CSR, 2003-04-22 + (:policy :fast) + (:translate symbol-value) + (:generator 8 + (let ((ret-lab (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst mov value + (make-ea :qword :base thread-base-tn :index value :scale 1)) + (inst cmp value no-tls-value-marker-widetag) + (inst jmp :ne ret-lab) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label ret-lab))))) -(define-vop (locked-symbol-global-value-add) - (:args (object :scs (descriptor-reg) :to :result) - (value :scs (any-reg) :target result)) - (:arg-types * tagged-num) - (:results (result :scs (any-reg) :from (:argument 1))) - (:policy :fast) - (:translate locked-symbol-global-value-add) - (:result-types tagged-num) - (:policy :fast-safe) - (:generator 4 - (move result value) - (inst lock) - (inst add (make-ea :qword :base object - :disp (- (* symbol-value-slot n-word-bytes) - other-pointer-lowtag)) - value))) +#!-sb-thread +(progn + (define-vop (symbol-value symbol-global-value) + (:translate symbol-value)) + (define-vop (fast-symbol-value fast-symbol-global-value) + (:translate symbol-value)) + (define-vop (set %set-symbol-global-value))) #!+sb-thread (define-vop (boundp) (:translate boundp) (:policy :fast-safe) (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) + (:conditional :ne) (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value) (:generator 9 (let ((check-unbound-label (gen-label))) @@ -237,21 +211,18 @@ (inst jmp :ne check-unbound-label) (loadw value object symbol-value-slot other-pointer-lowtag) (emit-label check-unbound-label) - (inst cmp value unbound-marker-widetag) - (inst jmp (if not-p :e :ne) target)))) + (inst cmp value unbound-marker-widetag)))) #!-sb-thread (define-vop (boundp) (:translate boundp) (:policy :fast-safe) (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) + (:conditional :ne) (:generator 9 (inst cmp (make-ea-for-object-slot object symbol-value-slot other-pointer-lowtag) - unbound-marker-widetag) - (inst jmp (if not-p :e :ne) target))) + unbound-marker-widetag))) (define-vop (symbol-hash) @@ -525,19 +496,28 @@ (defun make-ea-for-raw-slot (object index instance-length &optional (adjustment 0)) - (etypecase index - (tn - (make-ea :qword :base object :index instance-length - :disp (+ (* (1- instance-slots-offset) n-word-bytes) - (- instance-pointer-lowtag) - adjustment))) - (integer - (make-ea :qword :base object :index instance-length - :scale 8 - :disp (+ (* (1- instance-slots-offset) n-word-bytes) - (- instance-pointer-lowtag) - adjustment - (- (fixnumize index))))))) + (if (integerp instance-length) + ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length + ;; at compile time. + (make-ea :qword + :base object + :disp (+ (* (- instance-length instance-slots-offset index) + n-word-bytes) + (- instance-pointer-lowtag) + adjustment)) + (etypecase index + (tn + (make-ea :qword :base object :index instance-length + :disp (+ (* (1- instance-slots-offset) n-word-bytes) + (- instance-pointer-lowtag) + adjustment))) + (integer + (make-ea :qword :base object :index instance-length + :scale 8 + :disp (+ (* (1- instance-slots-offset) n-word-bytes) + (- instance-pointer-lowtag) + adjustment + (* index (- n-word-bytes)))))))) (define-vop (raw-instance-ref/word) (:translate %raw-instance-ref/word) @@ -550,7 +530,7 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) (inst mov value (make-ea-for-raw-slot object index tmp)))) @@ -583,7 +563,7 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) (inst mov (make-ea-for-raw-slot object index tmp) value) (move result value))) @@ -607,6 +587,33 @@ (inst mov (make-ea-for-raw-slot object index tmp) value) (move result value))) +(define-vop (raw-instance-init/word) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg))) + (:arg-types * unsigned-num) + (:info instance-length index) + (:generator 4 + (inst mov (make-ea-for-raw-slot object index instance-length) value))) + +(define-vop (raw-instance-atomic-incf-c/word) + (:translate %raw-instance-atomic-incf/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (diff :scs (signed-reg) :target result)) + (:arg-types * (:constant (load/store-index #.n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset)) + signed-num) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst xadd (make-ea-for-raw-slot object index tmp) diff :lock) + (move result diff))) + (define-vop (raw-instance-ref/single) (:translate %raw-instance-ref/single) (:policy :fast-safe) @@ -619,7 +626,7 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) (inst movss value (make-ea-for-raw-slot object index tmp)))) @@ -652,11 +659,10 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) (inst movss (make-ea-for-raw-slot object index tmp) value) - (unless (location= result value) - (inst movss result value)))) + (move result value))) (define-vop (raw-instance-set-c/single) (:translate %raw-instance-set/single) @@ -675,8 +681,15 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (inst movss (make-ea-for-raw-slot object index tmp) value) - (unless (location= result value) - (inst movss result value)))) + (move result value))) + +(define-vop (raw-instance-init/single) + (:args (object :scs (descriptor-reg)) + (value :scs (single-reg))) + (:arg-types * single-float) + (:info instance-length index) + (:generator 4 + (inst movss (make-ea-for-raw-slot object index instance-length) value))) (define-vop (raw-instance-ref/double) (:translate %raw-instance-ref/double) @@ -690,7 +703,7 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) (inst movsd value (make-ea-for-raw-slot object index tmp)))) @@ -723,11 +736,10 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) (inst movsd (make-ea-for-raw-slot object index tmp) value) - (unless (location= result value) - (inst movsd result value)))) + (move result value))) (define-vop (raw-instance-set-c/double) (:translate %raw-instance-set/double) @@ -746,8 +758,15 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (inst movsd (make-ea-for-raw-slot object index tmp) value) - (unless (location= result value) - (inst movsd result value)))) + (move result value))) + +(define-vop (raw-instance-init/double) + (:args (object :scs (descriptor-reg)) + (value :scs (double-reg))) + (:arg-types * double-float) + (:info instance-length index) + (:generator 4 + (inst movsd (make-ea-for-raw-slot object index instance-length) value))) (define-vop (raw-instance-ref/complex-single) (:translate %raw-instance-ref/complex-single) @@ -761,12 +780,9 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (let ((real-tn (complex-single-reg-real-tn value))) - (inst movss real-tn (make-ea-for-raw-slot object index tmp))) - (let ((imag-tn (complex-single-reg-imag-tn value))) - (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4))))) + (inst movq value (make-ea-for-raw-slot object index tmp)))) (define-vop (raw-instance-ref-c/complex-single) (:translate %raw-instance-ref/complex-single) @@ -782,10 +798,7 @@ (:generator 4 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (let ((real-tn (complex-single-reg-real-tn value))) - (inst movss real-tn (make-ea-for-raw-slot object index tmp))) - (let ((imag-tn (complex-single-reg-imag-tn value))) - (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4))))) + (inst movq value (make-ea-for-raw-slot object index tmp)))) (define-vop (raw-instance-set/complex-single) (:translate %raw-instance-set/complex-single) @@ -800,18 +813,10 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (let ((value-real (complex-single-reg-real-tn value)) - (result-real (complex-single-reg-real-tn result))) - (inst movss (make-ea-for-raw-slot object index tmp) value-real) - (unless (location= value-real result-real) - (inst movss result-real value-real))) - (let ((value-imag (complex-single-reg-imag-tn value)) - (result-imag (complex-single-reg-imag-tn result))) - (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag) - (unless (location= value-imag result-imag) - (inst movss result-imag value-imag))))) + (move result value) + (inst movq (make-ea-for-raw-slot object index tmp) value))) (define-vop (raw-instance-set-c/complex-single) (:translate %raw-instance-set/complex-single) @@ -829,16 +834,16 @@ (:generator 4 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (let ((value-real (complex-single-reg-real-tn value)) - (result-real (complex-single-reg-real-tn result))) - (inst movss (make-ea-for-raw-slot object index tmp) value-real) - (unless (location= value-real result-real) - (inst movss result-real value-real))) - (let ((value-imag (complex-single-reg-imag-tn value)) - (result-imag (complex-single-reg-imag-tn result))) - (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag) - (unless (location= value-imag result-imag) - (inst movss result-imag value-imag))))) + (move result value) + (inst movq (make-ea-for-raw-slot object index tmp) value))) + +(define-vop (raw-instance-init/complex-single) + (:args (object :scs (descriptor-reg)) + (value :scs (complex-single-reg))) + (:arg-types * complex-single-float) + (:info instance-length index) + (:generator 4 + (inst movq (make-ea-for-raw-slot object index instance-length) value))) (define-vop (raw-instance-ref/complex-double) (:translate %raw-instance-ref/complex-double) @@ -852,12 +857,9 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (let ((real-tn (complex-double-reg-real-tn value))) - (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8))) - (let ((imag-tn (complex-double-reg-imag-tn value))) - (inst movsd imag-tn (make-ea-for-raw-slot object index tmp))))) + (inst movdqu value (make-ea-for-raw-slot object index tmp -8)))) (define-vop (raw-instance-ref-c/complex-double) (:translate %raw-instance-ref/complex-double) @@ -873,10 +875,7 @@ (:generator 4 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (let ((real-tn (complex-double-reg-real-tn value))) - (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8))) - (let ((imag-tn (complex-double-reg-imag-tn value))) - (inst movsd imag-tn (make-ea-for-raw-slot object index tmp))))) + (inst movdqu value (make-ea-for-raw-slot object index tmp -8)))) (define-vop (raw-instance-set/complex-double) (:translate %raw-instance-set/complex-double) @@ -891,18 +890,10 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (let ((value-real (complex-double-reg-real-tn value)) - (result-real (complex-double-reg-real-tn result))) - (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real) - (unless (location= value-real result-real) - (inst movsd result-real value-real))) - (let ((value-imag (complex-double-reg-imag-tn value)) - (result-imag (complex-double-reg-imag-tn result))) - (inst movsd (make-ea-for-raw-slot object index tmp) value-imag) - (unless (location= value-imag result-imag) - (inst movsd result-imag value-imag))))) + (move result value) + (inst movdqu (make-ea-for-raw-slot object index tmp -8) value))) (define-vop (raw-instance-set-c/complex-double) (:translate %raw-instance-set/complex-double) @@ -920,13 +911,13 @@ (:generator 4 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (let ((value-real (complex-double-reg-real-tn value)) - (result-real (complex-double-reg-real-tn result))) - (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real) - (unless (location= value-real result-real) - (inst movsd result-real value-real))) - (let ((value-imag (complex-double-reg-imag-tn value)) - (result-imag (complex-double-reg-imag-tn result))) - (inst movsd (make-ea-for-raw-slot object index tmp) value-imag) - (unless (location= value-imag result-imag) - (inst movsd result-imag value-imag))))) + (move result value) + (inst movdqu (make-ea-for-raw-slot object index tmp -8) value))) + +(define-vop (raw-instance-init/complex-double) + (:args (object :scs (descriptor-reg)) + (value :scs (complex-double-reg))) + (:arg-types * complex-double-float) + (:info instance-length index) + (:generator 4 + (inst movdqu (make-ea-for-raw-slot object index instance-length -8) value)))