X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fcell.lisp;h=016a85e70abd87077846d75e43895cf0ec5580ee;hb=69d60b456b07a0256f08df0d02484f361ce5737c;hp=19587781e238ff1a246f41af40cc3a3cf3694274;hpb=e365f2f7a9c66d307b48fee70778f4eaa84bdcc0;p=sbcl.git diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index 1958778..016a85e 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -46,7 +46,7 @@ (make-ea :dword :base object :disp (- (* offset n-word-bytes) lowtag)) (logior (ash (char-code val) n-widetag-bits) - base-char-widetag))))) + character-widetag))))) ;; Else, value not immediate. (storew value object offset lowtag)))) @@ -63,8 +63,7 @@ (define-vop (set) (:args (symbol :scs (descriptor-reg)) (value :scs (descriptor-reg any-reg))) - (:translate sb!kernel:%set-symbol-value) - (:temporary (:sc descriptor-reg ) tls) + (:temporary (:sc descriptor-reg) tls) ;;(:policy :fast-safe) (:generator 4 (let ((global-val (gen-label)) @@ -122,8 +121,22 @@ #!+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 (:policy :fast) - (:translate symbol-value)) + (: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 :index value :scale 1)) + (inst cmp value unbound-marker-widetag) + (inst jmp :ne ret-lab) + (loadw value object symbol-value-slot other-pointer-lowtag) + (emit-label ret-lab)))) #!-sb-thread (define-vop (symbol-value) @@ -145,13 +158,24 @@ (:policy :fast) (:translate symbol-value)) -(defknown fast-symbol-global-value-xadd (symbol fixnum) fixnum ()) +(defknown locked-symbol-global-value-add (symbol fixnum) fixnum ()) -(define-vop (fast-symbol-global-value-xadd cell-xadd) - (:variant symbol-value-slot other-pointer-lowtag) +(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 fast-symbol-global-value-xadd) - (:arg-types * tagged-num)) + (:translate locked-symbol-global-value-add) + (:result-types tagged-num) + (:policy :fast-safe) + (:generator 4 + (move result value) + (inst lock) + (inst add (make-ea :dword :base object + :disp (- (* symbol-value-slot n-word-bytes) + other-pointer-lowtag)) + value))) #!+sb-thread (define-vop (boundp) @@ -241,7 +265,7 @@ fun-pointer-lowtag))) (inst cmp type simple-fun-header-widetag) (inst jmp :e normal-fn) - (inst lea raw (make-fixup (extern-alien-name "closure_tramp") :foreign)) + (inst lea raw (make-fixup "closure_tramp" :foreign)) NORMAL-FN (storew function fdefn fdefn-fun-slot other-pointer-lowtag) (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag) @@ -254,7 +278,7 @@ (:results (result :scs (descriptor-reg))) (:generator 38 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag) - (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign) + (storew (make-fixup "undefined_tramp" :foreign) fdefn fdefn-raw-addr-slot other-pointer-lowtag) (move result fdefn))) @@ -449,6 +473,7 @@ (:policy :fast-safe) (:generator 5 (move eax old-value) + (inst lock) (inst cmpxchg (make-ea :dword :base object :index slot :scale 1 :disp (- (* instance-slots-offset n-word-bytes) instance-pointer-lowtag)) @@ -464,3 +489,340 @@ (define-full-setter code-header-set * 0 other-pointer-lowtag (any-reg descriptor-reg) * code-header-set) + + + +;;;; raw instance slot accessors + +(define-vop (raw-instance-ref/word) + (:translate %raw-instance-ref/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (inst mov + value + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))))) + +(define-vop (raw-instance-set/word) + (:translate %raw-instance-set/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :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) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (inst mov + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + value) + (move result value))) + +(define-vop (raw-instance-ref/single) + (:translate %raw-instance-ref/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (with-empty-tn@fp-top(value) + (inst fld + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)))))) + +(define-vop (raw-instance-set/single) + (:translate %raw-instance-set/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) + (:arg-types * tagged-num single-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (unless (zerop (tn-offset value)) + (inst fxch value)) + (inst fst + (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))) + (cond + ((zerop (tn-offset value)) + (unless (zerop (tn-offset result)) + (inst fst result))) + ((zerop (tn-offset result)) + (inst fst value)) + (t + (unless (location= value result) + (inst fst result)) + (inst fxch value))))) + +(define-vop (raw-instance-ref/double) + (:translate %raw-instance-ref/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (with-empty-tn@fp-top(value) + (inst fldd + (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)))))) + +(define-vop (raw-instance-set/double) + (:translate %raw-instance-set/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) + (:arg-types * tagged-num double-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (unless (zerop (tn-offset value)) + (inst fxch value)) + (inst fstd + (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag))) + (cond + ((zerop (tn-offset value)) + (unless (zerop (tn-offset result)) + (inst fstd result))) + ((zerop (tn-offset result)) + (inst fstd value)) + (t + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))) + +(define-vop (raw-instance-ref/complex-single) + (:translate %raw-instance-ref/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (let ((real-tn (complex-single-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fld (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) + n-word-bytes) + instance-pointer-lowtag))))) + (let ((imag-tn (complex-single-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fld (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) + n-word-bytes) + instance-pointer-lowtag))))))) + +(define-vop (raw-instance-set/complex-single) + (:translate %raw-instance-set/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types * positive-fixnum complex-single-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 5 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0. + (inst fst (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) + n-word-bytes) + instance-pointer-lowtag))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fst result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fst (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) + n-word-bytes) + instance-pointer-lowtag))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fst value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fst result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst fxch value-imag) + (inst fst (make-ea :dword + :base object + :index tmp + :disp (- (* (1- instance-slots-offset) + n-word-bytes) + instance-pointer-lowtag))) + (unless (location= value-imag result-imag) + (inst fst result-imag)) + (inst fxch value-imag)))) + +(define-vop (raw-instance-ref/complex-double) + (:translate %raw-instance-ref/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 7 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (let ((real-tn (complex-double-reg-real-tn value))) + (with-empty-tn@fp-top (real-tn) + (inst fldd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 4) + n-word-bytes) + instance-pointer-lowtag))))) + (let ((imag-tn (complex-double-reg-imag-tn value))) + (with-empty-tn@fp-top (imag-tn) + (inst fldd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) + n-word-bytes) + instance-pointer-lowtag))))))) + +(define-vop (raw-instance-set/complex-double) + (:translate %raw-instance-set/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types * positive-fixnum complex-double-float) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 20 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst shl tmp 2) + (inst sub tmp index) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (cond ((zerop (tn-offset value-real)) + ;; Value is in ST0. + (inst fstd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 4) + n-word-bytes) + instance-pointer-lowtag))) + (unless (zerop (tn-offset result-real)) + ;; Value is in ST0 but not result. + (inst fstd result-real))) + (t + ;; Value is not in ST0. + (inst fxch value-real) + (inst fstd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 4) + n-word-bytes) + instance-pointer-lowtag))) + (cond ((zerop (tn-offset result-real)) + ;; The result is in ST0. + (inst fstd value-real)) + (t + ;; Neither value or result are in ST0 + (unless (location= value-real result-real) + (inst fstd result-real)) + (inst fxch value-real)))))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst fxch value-imag) + (inst fstd (make-ea :dword + :base object + :index tmp + :disp (- (* (- instance-slots-offset 2) + n-word-bytes) + instance-pointer-lowtag))) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag))))