X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fx86%2Fcell.lisp;h=8a93d7be3d0ddc795281c6e853cc689745844806;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=25900003756c55f682c8ab8306b868ff4cdc5bfb;hpb=79a8e51bf4b06a5bd57bc90233605f98fee3b041;p=sbcl.git diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index 2590000..8a93d7b 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) @@ -71,7 +73,8 @@ (progn (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) ;; Thread-local area, no LOCK needed. - (inst cmpxchg (make-ea :dword :base tls) new :fs) + (with-tls-ea (EA :base tls :base-already-live-p t) + (inst cmpxchg EA new :maybe-fs)) (inst cmp eax no-tls-value-marker-widetag) (inst jmp :ne check) (move eax old)) @@ -115,9 +118,10 @@ (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) + (with-tls-ea (EA :base tls :base-already-live-p t) + (inst cmp EA no-tls-value-marker-widetag :maybe-fs) + (inst jmp :z global-val) + (inst mov EA value :maybe-fs)) (inst jmp done) (emit-label global-val) (storew value symbol symbol-value-slot other-pointer-lowtag) @@ -137,7 +141,8 @@ (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) + (with-tls-ea (EA :base value :base-already-live-p t) + (inst mov value EA :maybe-fs)) (inst cmp value no-tls-value-marker-widetag) (inst jmp :ne check-unbound-label) (loadw value object symbol-value-slot other-pointer-lowtag) @@ -157,7 +162,8 @@ (: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) + (with-tls-ea (EA :base value :base-already-live-p t) + (inst mov value EA :maybe-fs)) (inst cmp value no-tls-value-marker-widetag) (inst jmp :ne ret-lab) (loadw value object symbol-value-slot other-pointer-lowtag) @@ -181,7 +187,8 @@ (:generator 9 (let ((check-unbound-label (gen-label))) (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst mov value (make-ea :dword :base value) :fs) + (with-tls-ea (EA :base value :base-already-live-p t) + (inst mov value EA :maybe-fs)) (inst cmp value no-tls-value-marker-widetag) (inst jmp :ne check-unbound-label) (loadw value object symbol-value-slot other-pointer-lowtag) @@ -267,7 +274,8 @@ ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and ;;; the symbol on the binding stack and stuff the new value into the ;;; symbol. - +;;; See the "Chapter 9: Specials" of the SBCL Internals Manual. +;; ;;; 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 @@ -277,30 +285,36 @@ (define-vop (bind) (:args (val :scs (any-reg descriptor-reg)) (symbol :scs (descriptor-reg))) - (:temporary (:sc unsigned-reg) tls-index bsp) + (:temporary (:sc unsigned-reg) tls-index bsp + #!+win32 temp) (:generator 10 - (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) - (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 push (make-ea :dword :base tls-index) :fs) - (popw bsp (- binding-value-slot binding-size)) - (storew symbol bsp (- binding-symbol-slot binding-size)) - (inst mov (make-ea :dword :base tls-index) val :fs)))) + (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 test tls-index tls-index) + (inst jmp :ne tls-index-valid) + (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)) + TLS-INDEX-VALID + ;; with-tls-ea on win32 causes tls-index to be an absolute address + ;; which is problematic when UNBIND uses with-tls-ea too. + #!+win32(move temp tls-index) + (with-tls-ea (EA :base tls-index :base-already-live-p t) + (inst push EA :maybe-fs) + (popw bsp (- binding-value-slot binding-size)) + (storew #!-win32 tls-index + #!+win32 temp + bsp (- binding-symbol-slot binding-size)) + (inst mov EA val :maybe-fs)))) #!-sb-thread (define-vop (bind) @@ -322,15 +336,15 @@ (:generator 0 (load-binding-stack-pointer bsp) ;; 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) + (loadw tls-index bsp (- binding-symbol-slot binding-size)) ;; 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) + (with-tls-ea (EA :base tls-index :base-already-live-p t) + (inst mov EA temp :maybe-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)) + (storew 0 bsp binding-symbol-slot) + (storew 0 bsp binding-value-slot) (store-binding-stack-pointer bsp))) #!-sb-thread @@ -349,30 +363,28 @@ (define-vop (unbind-to-here) (:args (where :scs (descriptor-reg any-reg))) - (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index) + (:temporary (:sc unsigned-reg) symbol value bsp) (:generator 0 (load-binding-stack-pointer bsp) (inst cmp where bsp) (inst jmp :e done) LOOP - (loadw symbol bsp (- binding-symbol-slot binding-size)) - (inst or symbol symbol) + (inst sub bsp (* binding-size n-word-bytes)) + (loadw symbol bsp binding-symbol-slot) + (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) (inst jmp :eq skip) - (loadw value bsp (- binding-value-slot binding-size)) + (loadw value bsp binding-value-slot) #!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag) - - #!+sb-thread (loadw - tls-index symbol symbol-tls-index-slot other-pointer-lowtag) - #!+sb-thread (inst mov (make-ea :dword :base tls-index) value :fs) - (storew 0 bsp (- binding-symbol-slot binding-size)) + #!+sb-thread (with-tls-ea (EA :base symbol :base-already-live-p t) + (inst mov EA value :maybe-fs)) + (storew 0 bsp binding-symbol-slot) SKIP - (storew 0 bsp (- binding-value-slot binding-size)) - (inst sub bsp (* binding-size n-word-bytes)) + (storew 0 bsp binding-value-slot) (inst cmp where bsp) (inst jmp :ne loop) (store-binding-stack-pointer bsp) @@ -418,6 +430,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 @@ -504,7 +522,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)))) @@ -522,7 +540,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))) @@ -540,8 +558,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) @@ -549,7 +567,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 xadd (make-ea-for-raw-slot object index tmp 1) diff :lock) (move result diff))) @@ -566,7 +584,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))))) @@ -585,7 +603,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)) @@ -622,7 +640,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))))) @@ -641,7 +659,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)) @@ -679,7 +697,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) @@ -702,7 +720,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))) @@ -758,7 +776,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) @@ -781,7 +799,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)))