X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fcell.lisp;h=a049fcdaf322a707a51f0d86fc1bfeb445685db2;hb=70c6facc145eaf5ca368528b04df63f730746b1f;hp=de45ddf75b91516af01efd4efcac20bb83b676a2;hpb=6a62de3cd5eacf0c2236c70b1f7dc27d9f009712;p=sbcl.git diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index de45ddf..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) @@ -302,54 +292,39 @@ ;;; the symbol on the binding stack and stuff the new value into the ;;; symbol. +;;; FIXME: Split into DYNBIND and BIND: DYNBIND needs to ensure +;;; TLS-INDEX, whereas BIND should assume it is already in place. Make +;;; LET &co compile into BIND, and PROGV into DYNBIND, plus ensure +;;; TLS-INDEX at compile-time, and make loader and dumper preserve +;;; the existence of a TLS-INDEX. #!+sb-thread (define-vop (bind) (:args (val :scs (any-reg descriptor-reg)) (symbol :scs (descriptor-reg))) - (:temporary (:sc descriptor-reg :offset eax-offset) eax) (: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) - (inst xor eax eax) - (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*) 4) ; 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 call (make-fixup + (ecase (tn-offset tls-index) + (#.eax-offset 'alloc-tls-index-in-eax) + (#.ebx-offset 'alloc-tls-index-in-ebx) + (#.ecx-offset 'alloc-tls-index-in-ecx) + (#.edx-offset 'alloc-tls-index-in-edx) + (#.edi-offset 'alloc-tls-index-in-edi) + (#.esi-offset 'alloc-tls-index-in-esi)) + :assembly-routine)) (emit-label tls-index-valid) - (inst fs-segment-prefix) - (inst mov eax (make-ea :dword :base tls-index)) - (storew eax bsp (- binding-value-slot binding-size)) + (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) @@ -365,20 +340,18 @@ (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) - (inst fs-segment-prefix) - (inst mov (make-ea :dword :base tls-index) value) - + ;; 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, then restore it to the TLS area. + (loadw temp bsp (- binding-value-slot binding-size)) + (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)) (inst sub bsp (* binding-size n-word-bytes)) @@ -418,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 @@ -517,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) @@ -567,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) @@ -614,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) @@ -661,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) @@ -727,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) @@ -792,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))))))