X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fcell.lisp;h=d90f81b8dd18c7e27537121e87c69a2ac8e78599;hb=013da4580d11f9174babda0781d3b42431ec2c4d;hp=3d85b6b441969e1ff764551abcf6c082c11b81d2;hpb=6a62de3cd5eacf0c2236c70b1f7dc27d9f009712;p=sbcl.git diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 3d85b6b..d90f81b 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,11 +211,10 @@ (: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) @@ -281,7 +277,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) @@ -327,46 +323,37 @@ (define-vop (bind) (:args (val :scs (any-reg descriptor-reg)) (symbol :scs (descriptor-reg))) - (:temporary (:sc descriptor-reg :offset rax-offset) rax) (:temporary (:sc unsigned-reg) tls-index bsp) (:generator 10 - (let ((tls-index-valid (gen-label)) - (get-tls-index-lock (gen-label)) - (release-tls-index-lock (gen-label))) + (let ((tls-index-valid (gen-label))) (load-binding-stack-pointer bsp) (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) (inst add bsp (* binding-size n-word-bytes)) (store-binding-stack-pointer bsp) (inst or tls-index tls-index) (inst jmp :ne tls-index-valid) - - ;; FIXME: - ;; * We should ensure the existence of TLS index for LET-bound specials - ;; at compile/load time, and use write a FAST-BIND for use with those. - ;; * PROGV will need to do this, but even there this should not be inline. - ;; This is probably best moved to C, since dynbind.c also needs to do this. - (pseudo-atomic - (emit-label get-tls-index-lock) - (inst mov tls-index 1) - (zeroize rax) - (inst lock) - (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) tls-index) - (inst jmp :ne get-tls-index-lock) - ;; now with the lock held, see if the symbol's tls index has - ;; been set in the meantime - (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) - (inst or tls-index tls-index) - (inst jmp :ne release-tls-index-lock) - ;; allocate a new tls-index - (load-symbol-value tls-index *free-tls-index*) - (inst add (make-ea-for-symbol-value *free-tls-index*) 8) ; fixnum + 1 - (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag) - (emit-label release-tls-index-lock) - (store-symbol-value 0 *tls-index-lock*)) - + (inst mov tls-index symbol) + (inst lea temp-reg-tn + (make-ea :qword :disp + (make-fixup (ecase (tn-offset tls-index) + (#.rax-offset 'alloc-tls-index-in-rax) + (#.rcx-offset 'alloc-tls-index-in-rcx) + (#.rdx-offset 'alloc-tls-index-in-rdx) + (#.rbx-offset 'alloc-tls-index-in-rbx) + (#.rsi-offset 'alloc-tls-index-in-rsi) + (#.rdi-offset 'alloc-tls-index-in-rdi) + (#.r8-offset 'alloc-tls-index-in-r8) + (#.r9-offset 'alloc-tls-index-in-r9) + (#.r10-offset 'alloc-tls-index-in-r10) + (#.r12-offset 'alloc-tls-index-in-r12) + (#.r13-offset 'alloc-tls-index-in-r13) + (#.r14-offset 'alloc-tls-index-in-r14) + (#.r15-offset 'alloc-tls-index-in-r15)) + :assembly-routine))) + (inst call temp-reg-tn) (emit-label tls-index-valid) - (inst mov rax (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)) - (storew rax bsp (- binding-value-slot binding-size)) + (inst push (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)) + (popw bsp (- binding-value-slot binding-size)) (storew symbol bsp (- binding-symbol-slot binding-size)) (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index) val)))) @@ -385,20 +372,19 @@ (storew symbol bsp (- binding-symbol-slot binding-size)) (storew val symbol symbol-value-slot other-pointer-lowtag))) - #!+sb-thread (define-vop (unbind) - ;; four temporaries? - (:temporary (:sc unsigned-reg) symbol value bsp tls-index) + (:temporary (:sc unsigned-reg) temp bsp tls-index) (:generator 0 (load-binding-stack-pointer bsp) - (loadw symbol bsp (- binding-symbol-slot binding-size)) - (loadw value bsp (- binding-value-slot binding-size)) - - (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + ;; Load SYMBOL from stack, and get the TLS-INDEX + (loadw temp bsp (- binding-symbol-slot binding-size)) + (loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag) + ;; Load VALUE from stack, the restore it to the TLS area. + (loadw temp bsp (- binding-value-slot binding-size)) (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index) - value) - + temp) + ;; Zero out the stack. (storew 0 bsp (- binding-symbol-slot binding-size)) (storew 0 bsp (- binding-value-slot binding-size)) (inst sub bsp (* binding-size n-word-bytes)) @@ -417,7 +403,6 @@ (inst sub bsp (* binding-size n-word-bytes)) (store-symbol-value bsp *binding-stack-pointer*))) - (define-vop (unbind-to-here) (:args (where :scs (descriptor-reg any-reg))) (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index) @@ -536,19 +521,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) @@ -618,6 +612,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) @@ -689,6 +710,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) @@ -760,6 +789,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) @@ -851,6 +888,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) @@ -941,3 +989,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))))