X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fcell.lisp;h=a049fcdaf322a707a51f0d86fc1bfeb445685db2;hb=70c6facc145eaf5ca368528b04df63f730746b1f;hp=08862bf8cddc5866c30313cbae5d4bf573bab33c;hpb=91249484164b74b9df8b65f8ecd1fe228a08276c;p=sbcl.git diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index 08862bf..a049fcd 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -42,11 +42,9 @@ (:results (result :scs (descriptor-reg any-reg))) (:generator 5 (move eax old) - #!+sb-thread - (inst lock) (inst cmpxchg (make-ea :dword :base object :disp (- (* offset n-word-bytes) lowtag)) - new) + new :lock) (move result eax))) ;;;; symbol hacking VOPs @@ -66,23 +64,21 @@ ;; This code has to 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 eax old) #!+sb-thread (progn (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) ;; Thread-local area, no LOCK needed. - (inst fs-segment-prefix) - (inst cmpxchg (make-ea :dword :base tls) new) + (inst cmpxchg (make-ea :dword :base tls) new :fs) (inst cmp eax no-tls-value-marker-widetag) (inst jmp :ne check) - (move eax old) - (inst lock)) + (move eax old)) (inst cmpxchg (make-ea :dword :base symbol :disp (- (* symbol-value-slot n-word-bytes) other-pointer-lowtag)) - new) + new :lock) (emit-label check) (move result eax) (inst cmp result unbound-marker-widetag) @@ -103,11 +99,9 @@ (let ((global-val (gen-label)) (done (gen-label))) (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) - (inst fs-segment-prefix) - (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag) + (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag :fs) (inst jmp :z global-val) - (inst fs-segment-prefix) - (inst mov (make-ea :dword :base tls) value) + (inst mov (make-ea :dword :base tls) value :fs) (inst jmp done) (emit-label global-val) (storew value symbol symbol-value-slot other-pointer-lowtag) @@ -130,11 +124,10 @@ (: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 fs-segment-prefix) - (inst mov value (make-ea :dword :base value)) + (inst mov value (make-ea :dword :base value) :fs) (inst cmp value no-tls-value-marker-widetag) (inst jmp :ne check-unbound-label) (loadw value object symbol-value-slot other-pointer-lowtag) @@ -155,8 +148,7 @@ (:generator 8 (let ((ret-lab (gen-label))) (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst fs-segment-prefix) - (inst mov value (make-ea :dword :base value)) + (inst mov value (make-ea :dword :base value) :fs) (inst cmp value no-tls-value-marker-widetag) (inst jmp :ne ret-lab) (loadw value object symbol-value-slot other-pointer-lowtag) @@ -171,7 +163,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)))) @@ -195,10 +187,9 @@ (:policy :fast-safe) (:generator 4 (move result value) - (inst lock) (inst add (make-ea-for-object-slot object symbol-value-slot other-pointer-lowtag) - value))) + value :lock))) #!+sb-thread (define-vop (boundp) @@ -211,8 +202,7 @@ (:generator 9 (let ((check-unbound-label (gen-label))) (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst fs-segment-prefix) - (inst mov value (make-ea :dword :base value)) + (inst mov value (make-ea :dword :base value) :fs) (inst cmp value no-tls-value-marker-widetag) (inst jmp :ne check-unbound-label) (loadw value object symbol-value-slot other-pointer-lowtag) @@ -261,7 +251,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) @@ -331,12 +321,10 @@ (#.esi-offset 'alloc-tls-index-in-esi)) :assembly-routine)) (emit-label tls-index-valid) - (inst fs-segment-prefix) - (inst push (make-ea :dword :base tls-index)) + (inst push (make-ea :dword :base tls-index) :fs) (popw bsp (- binding-value-slot binding-size)) (storew symbol bsp (- binding-symbol-slot binding-size)) - (inst fs-segment-prefix) - (inst mov (make-ea :dword :base tls-index) val)))) + (inst mov (make-ea :dword :base tls-index) val :fs)))) #!-sb-thread (define-vop (bind) @@ -362,8 +350,7 @@ (loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag) ;; Load VALUE from stack, then restore it to the TLS area. (loadw temp bsp (- binding-value-slot binding-size)) - (inst fs-segment-prefix) - (inst mov (make-ea :dword :base tls-index) temp) + (inst mov (make-ea :dword :base tls-index) temp :fs) ;; Zero out the stack. (storew 0 bsp (- binding-symbol-slot binding-size)) (storew 0 bsp (- binding-value-slot binding-size)) @@ -404,8 +391,7 @@ #!+sb-thread (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) - #!+sb-thread (inst fs-segment-prefix) - #!+sb-thread (inst mov (make-ea :dword :base tls-index) value) + #!+sb-thread (inst mov (make-ea :dword :base tls-index) value :fs) (storew 0 bsp (- binding-symbol-slot binding-size)) SKIP @@ -503,20 +489,32 @@ ;;;; raw instance slot accessors (defun make-ea-for-raw-slot (object index instance-length n-words) - (sc-case index - (any-reg (make-ea :dword - :base object - :index instance-length - :disp (- (* (- instance-slots-offset n-words) - n-word-bytes) - instance-pointer-lowtag))) - (immediate (make-ea :dword :base object + (if (integerp instance-length) + ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length + ;; at compile time. + (make-ea :dword + :base object + :disp (- (* (- instance-length instance-slots-offset index (1- n-words)) + n-word-bytes) + instance-pointer-lowtag)) + (flet ((make-ea-using-value (value) + (make-ea :dword :base object :index instance-length :scale 4 :disp (- (* (- instance-slots-offset n-words) n-word-bytes) instance-pointer-lowtag - (fixnumize (tn-value index))))))) + (* value n-word-bytes))))) + (if (typep index 'tn) + (sc-case index + (any-reg (make-ea :dword + :base object + :index instance-length + :disp (- (* (- instance-slots-offset n-words) + n-word-bytes) + instance-pointer-lowtag))) + (immediate (make-ea-using-value (tn-value index)))) + (make-ea-using-value index))))) (define-vop (raw-instance-ref/word) (:translate %raw-instance-ref/word) @@ -553,6 +551,33 @@ (inst mov (make-ea-for-raw-slot object index tmp 1) 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 5 + (inst mov (make-ea-for-raw-slot object index instance-length 1) value))) + +(define-vop (raw-instance-atomic-incf/word) + (:translate %raw-instance-atomic-incf/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (diff :scs (signed-reg) :target result)) + (:arg-types * tagged-num signed-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (inst xadd (make-ea-for-raw-slot object index tmp 1) diff :lock) + (move result diff))) + (define-vop (raw-instance-ref/single) (:translate %raw-instance-ref/single) (:policy :fast-safe) @@ -600,6 +625,15 @@ (inst fst result)) (inst fxch 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 5 + (with-tn@fp-top (value) + (inst fst (make-ea-for-raw-slot object index instance-length 1))))) + (define-vop (raw-instance-ref/double) (:translate %raw-instance-ref/double) (:policy :fast-safe) @@ -647,6 +681,15 @@ (inst fstd result)) (inst fxch 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 5 + (with-tn@fp-top (value) + (inst fstd (make-ea-for-raw-slot object index instance-length 2))))) + (define-vop (raw-instance-ref/complex-single) (:translate %raw-instance-ref/complex-single) (:policy :fast-safe) @@ -713,6 +756,19 @@ (inst fst result-imag)) (inst fxch 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 5 + (let ((value-real (complex-single-reg-real-tn value))) + (with-tn@fp-top (value-real) + (inst fst (make-ea-for-raw-slot object index instance-length 2)))) + (let ((value-imag (complex-single-reg-imag-tn value))) + (with-tn@fp-top (value-imag) + (inst fst (make-ea-for-raw-slot object index instance-length 1)))))) + (define-vop (raw-instance-ref/complex-double) (:translate %raw-instance-ref/complex-double) (:policy :fast-safe) @@ -778,3 +834,16 @@ (unless (location= value-imag result-imag) (inst fstd result-imag)) (inst fxch 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 20 + (let ((value-real (complex-double-reg-real-tn value))) + (with-tn@fp-top (value-real) + (inst fstd (make-ea-for-raw-slot object index instance-length 4)))) + (let ((value-imag (complex-double-reg-imag-tn value))) + (with-tn@fp-top (value-imag) + (inst fstd (make-ea-for-raw-slot object index instance-length 2))))))