X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fcell.lisp;h=0239ac1ce78cedd68c784e2df8949afe36fbef7c;hb=b916eedb42ae51b5069f8e2b210649b897b2ec24;hp=753838a66920fcf4f8bb1a77fb37917b9891596b;hpb=880a863592743d82835e0fb4395301d6ab1f5127;p=sbcl.git diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index 753838a..0239ac1 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -30,6 +30,8 @@ (:generator 1 (storew (encode-value-if-immediate value) object offset lowtag))) +(define-vop (init-slot set-slot)) + (define-vop (compare-and-swap-slot) (:args (object :scs (descriptor-reg) :to :eval) (old :scs (descriptor-reg any-reg) :target eax) @@ -42,11 +44,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 @@ -73,99 +73,30 @@ (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) (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 fs-segment-prefix) - (inst cmp (make-ea :dword :base tls) no-tls-value-marker-widetag) - (inst jmp :z global-val) - (inst fs-segment-prefix) - (inst mov (make-ea :dword :base 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 fs-segment-prefix) - (inst mov value (make-ea :dword :base value)) - (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 fs-segment-prefix) - (inst mov value (make-ea :dword :base value)) - (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) @@ -176,62 +107,99 @@ (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 :dword :base tls) no-tls-value-marker-widetag :fs) + (inst jmp :z global-val) + (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) + (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 :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) + (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 :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) + (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-for-object-slot object symbol-value-slot - 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))) (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) (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) @@ -318,7 +286,7 @@ (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 test tls-index tls-index) (inst jmp :ne tls-index-valid) (inst mov tls-index symbol) (inst call (make-fixup @@ -331,12 +299,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 +328,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)) @@ -394,7 +359,7 @@ LOOP (loadw symbol bsp (- binding-symbol-slot binding-size)) - (inst or symbol symbol) + (inst test symbol symbol) (inst jmp :z skip) ;; Bind stack debug sentinels have the unbound marker in the symbol slot (inst cmp symbol unbound-marker-widetag) @@ -404,8 +369,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 @@ -456,6 +420,12 @@ (define-vop (closure-init slot-set) (:variant closure-info-offset fun-pointer-lowtag)) + +(define-vop (closure-init-from-fp) + (:args (object :scs (descriptor-reg))) + (:info offset) + (:generator 4 + (storew ebp-tn object (+ closure-info-offset offset) fun-pointer-lowtag))) ;;;; value cell hackery @@ -542,7 +512,7 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (when (sc-is index any-reg) - (inst shl tmp 2) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index)) (inst mov value (make-ea-for-raw-slot object index tmp 1)))) @@ -560,7 +530,7 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (when (sc-is index any-reg) - (inst shl tmp 2) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index)) (inst mov (make-ea-for-raw-slot object index tmp 1) value) (move result value))) @@ -578,8 +548,8 @@ (: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) + (diff :scs (unsigned-reg) :target result)) + (:arg-types * tagged-num unsigned-num) (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) @@ -587,11 +557,9 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (when (sc-is index any-reg) - (inst shl tmp 2) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index)) - #!+sb-thread - (inst lock) - (inst xadd (make-ea-for-raw-slot object index tmp 1) diff) + (inst xadd (make-ea-for-raw-slot object index tmp 1) diff :lock) (move result diff))) (define-vop (raw-instance-ref/single) @@ -606,7 +574,7 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (when (sc-is index any-reg) - (inst shl tmp 2) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index)) (with-empty-tn@fp-top(value) (inst fld (make-ea-for-raw-slot object index tmp 1))))) @@ -625,7 +593,7 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (when (sc-is index any-reg) - (inst shl tmp 2) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index)) (unless (zerop (tn-offset value)) (inst fxch value)) @@ -662,7 +630,7 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (when (sc-is index any-reg) - (inst shl tmp 2) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index)) (with-empty-tn@fp-top(value) (inst fldd (make-ea-for-raw-slot object index tmp 2))))) @@ -681,7 +649,7 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (when (sc-is index any-reg) - (inst shl tmp 2) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index)) (unless (zerop (tn-offset value)) (inst fxch value)) @@ -719,7 +687,7 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (when (sc-is index any-reg) - (inst shl tmp 2) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index)) (let ((real-tn (complex-single-reg-real-tn value))) (with-empty-tn@fp-top (real-tn) @@ -742,7 +710,7 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (when (sc-is index any-reg) - (inst shl tmp 2) + (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))) @@ -798,7 +766,7 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (when (sc-is index any-reg) - (inst shl tmp 2) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index)) (let ((real-tn (complex-double-reg-real-tn value))) (with-empty-tn@fp-top (real-tn) @@ -821,7 +789,7 @@ (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) (when (sc-is index any-reg) - (inst shl tmp 2) + (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)))