X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fcell.lisp;h=e82cdd472778714c18d0de2e8e11a1d99c421a0e;hb=8f45dd3a5a074998e1aa697ba8f2a8b1b7388427;hp=2f546a6c6355426f8f2f639ccaaa258066a4cd98;hpb=91249484164b74b9df8b65f8ecd1fe228a08276c;p=sbcl.git diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 2f546a6..e82cdd4 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 @@ -80,10 +78,10 @@ (:policy :fast-safe) (:vop-var vop) (:generator 15 - ;; This code has to pathological cases: NO-TLS-VALUE-MARKER + ;; This code has two pathological cases: NO-TLS-VALUE-MARKER ;; or UNBOUND-MARKER as NEW: in either case we would end up ;; doing possible damage with CMPXCHG -- so don't do that! - (let ((unbound (generate-error-code vop unbound-symbol-error symbol)) + (let ((unbound (generate-error-code vop 'unbound-symbol-error symbol)) (check (gen-label))) (move rax old) #!+sb-thread @@ -95,13 +93,12 @@ 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) @@ -149,7 +146,7 @@ (:save-p :compute-only) (:generator 9 (let* ((check-unbound-label (gen-label)) - (err-lab (generate-error-code vop unbound-symbol-error object)) + (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 @@ -190,7 +187,7 @@ (:vop-var vop) (:save-p :compute-only) (:generator 9 - (let ((err-lab (generate-error-code vop unbound-symbol-error object))) + (let ((err-lab (generate-error-code vop 'unbound-symbol-error object))) (loadw value object symbol-value-slot other-pointer-lowtag) (inst cmp value unbound-marker-widetag) (inst jmp :e err-lab)))) @@ -214,19 +211,17 @@ (: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))) + value :lock))) #!+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 +232,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) @@ -281,7 +273,7 @@ (:generator 10 (loadw value object fdefn-fun-slot other-pointer-lowtag) (inst cmp value nil-value) - (let ((err-lab (generate-error-code vop undefined-fun-error object))) + (let ((err-lab (generate-error-code vop 'undefined-fun-error object))) (inst jmp :e err-lab)))) (define-vop (set-fdefn-fun) @@ -525,19 +517,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) @@ -607,6 +608,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) @@ -678,6 +706,14 @@ (unless (location= result value) (inst movss 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) (:policy :fast-safe) @@ -749,6 +785,14 @@ (unless (location= result value) (inst movsd 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) (:policy :fast-safe) @@ -840,6 +884,17 @@ (unless (location= value-imag result-imag) (inst movss result-imag value-imag))))) +(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 + (let ((value-real (complex-single-reg-real-tn value))) + (inst movss (make-ea-for-raw-slot object index instance-length) value-real)) + (let ((value-imag (complex-single-reg-imag-tn value))) + (inst movss (make-ea-for-raw-slot object index instance-length 4) value-imag)))) + (define-vop (raw-instance-ref/complex-double) (:translate %raw-instance-ref/complex-double) (:policy :fast-safe) @@ -930,3 +985,14 @@ (inst movsd (make-ea-for-raw-slot object index tmp) value-imag) (unless (location= value-imag result-imag) (inst movsd result-imag value-imag))))) + +(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 + (let ((value-real (complex-double-reg-real-tn value))) + (inst movsd (make-ea-for-raw-slot object index instance-length -8) value-real)) + (let ((value-imag (complex-double-reg-imag-tn value))) + (inst movsd (make-ea-for-raw-slot object index instance-length) value-imag))))