X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fcell.lisp;h=811b480b719dc76975dd6d16e500ccd7842ad696;hb=ea3a2433c72ee97c5691c29d882a63e4d86f0a32;hp=f2387c7349b9652563e6c09e6b426173ce05bf8b;hpb=6f409fdfbd3d4a0c5c540de5a9371388c585cacb;p=sbcl.git diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index f2387c7..811b480 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -28,27 +28,7 @@ (:ignore name) (:results) (:generator 1 - (if (sc-is value immediate) - (let ((val (tn-value value))) - (etypecase val - (integer - (inst mov - (make-ea :dword :base object - :disp (- (* offset n-word-bytes) lowtag)) - (fixnumize val))) - (symbol - (inst mov - (make-ea :dword :base object - :disp (- (* offset n-word-bytes) lowtag)) - (+ nil-value (static-symbol-offset val)))) - (character - (inst mov - (make-ea :dword :base object - :disp (- (* offset n-word-bytes) lowtag)) - (logior (ash (char-code val) n-widetag-bits) - character-widetag))))) - ;; Else, value not immediate. - (storew value object offset lowtag)))) + (storew (encode-value-if-immediate value) object offset lowtag))) @@ -72,11 +52,10 @@ (inst or tls tls) (inst jmp :z global-val) (inst fs-segment-prefix) - (inst cmp (make-ea :dword :scale 1 :index tls) - no-tls-value-marker-widetag) + (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 :scale 1 :index tls) value) + (inst mov (make-ea :dword :base tls) value) (inst jmp done) (emit-label global-val) (storew value symbol symbol-value-slot other-pointer-lowtag) @@ -87,16 +66,6 @@ (define-vop (set cell-set) (:variant symbol-value-slot other-pointer-lowtag)) -;;; Do a cell ref with an error check for being unbound. -;;; XXX stil used? I can't see where -dan -(define-vop (checked-cell-ref) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (descriptor-reg any-reg))) - (:policy :fast-safe) - (:vop-var vop) - (:save-p :compute-only) - (:temporary (:sc descriptor-reg :from (:argument 0)) obj-temp)) - ;;; With Symbol-Value, we check that the value isn't the trap object. So ;;; Symbol-Value of NIL is NIL. #!+sb-thread @@ -113,7 +82,7 @@ (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 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) @@ -135,7 +104,7 @@ (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 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) @@ -175,9 +144,8 @@ (:generator 4 (move result value) (inst lock) - (inst add (make-ea :dword :base object - :disp (- (* symbol-value-slot n-word-bytes) - other-pointer-lowtag)) + (inst add (make-ea-for-object-slot object symbol-value-slot + other-pointer-lowtag) value))) #!+sb-thread @@ -192,7 +160,7 @@ (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 :index value :scale 1)) + (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) @@ -207,10 +175,10 @@ (:args (object :scs (descriptor-reg))) (:conditional) (:info target not-p) - (:temporary (:sc descriptor-reg :from (:argument 0)) value) (:generator 9 - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst cmp value unbound-marker-widetag) + (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))) @@ -255,9 +223,8 @@ (:generator 38 (load-type type function (- fun-pointer-lowtag)) (inst lea raw - (make-ea :byte :base function - :disp (- (* simple-fun-code-offset n-word-bytes) - fun-pointer-lowtag))) + (make-ea-for-object-slot function simple-fun-code-offset + fun-pointer-lowtag)) (inst cmp type simple-fun-header-widetag) (inst jmp :e normal-fn) (inst lea raw (make-fixup "closure_tramp" :foreign)) @@ -323,11 +290,11 @@ (emit-label tls-index-valid) (inst fs-segment-prefix) - (inst mov temp (make-ea :dword :scale 1 :index tls-index)) + (inst mov temp (make-ea :dword :base tls-index)) (storew temp bsp (- binding-value-slot binding-size)) (storew symbol bsp (- binding-symbol-slot binding-size)) (inst fs-segment-prefix) - (inst mov (make-ea :dword :scale 1 :index tls-index) val)))) + (inst mov (make-ea :dword :base tls-index) val)))) #!-sb-thread (define-vop (bind) @@ -355,10 +322,10 @@ (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) (inst fs-segment-prefix) - (inst mov (make-ea :dword :scale 1 :index tls-index) value) + (inst mov (make-ea :dword :base tls-index) value) - (storew 0 bsp (- binding-value-slot binding-size)) (storew 0 bsp (- binding-symbol-slot binding-size)) + (storew 0 bsp (- binding-value-slot binding-size)) (inst sub bsp (* binding-size n-word-bytes)) (store-binding-stack-pointer bsp))) @@ -370,8 +337,8 @@ (loadw symbol bsp (- binding-symbol-slot binding-size)) (loadw value bsp (- binding-value-slot binding-size)) (storew value symbol symbol-value-slot other-pointer-lowtag) - (storew 0 bsp (- binding-value-slot binding-size)) (storew 0 bsp (- binding-symbol-slot binding-size)) + (storew 0 bsp (- binding-value-slot binding-size)) (inst sub bsp (* binding-size n-word-bytes)) (store-symbol-value bsp *binding-stack-pointer*))) @@ -394,11 +361,11 @@ #!+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 :scale 1 :index tls-index) value) - (storew 0 bsp (- binding-value-slot binding-size)) + #!+sb-thread (inst mov (make-ea :dword :base tls-index) value) (storew 0 bsp (- binding-symbol-slot binding-size)) SKIP + (storew 0 bsp (- binding-value-slot binding-size)) (inst sub bsp (* binding-size n-word-bytes)) (inst cmp where bsp) (inst jmp :ne loop) @@ -422,9 +389,6 @@ funcallable-instance-info-offset fun-pointer-lowtag (descriptor-reg any-reg) * %funcallable-instance-info) -(define-vop (funcallable-instance-lexenv cell-ref) - (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag)) - (define-vop (closure-ref slot-ref) (:variant closure-info-offset fun-pointer-lowtag)) @@ -451,38 +415,20 @@ (loadw res struct 0 instance-pointer-lowtag) (inst shr res n-widetag-bits))) -(define-full-reffer instance-index-ref * instance-slots-offset - instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref) - -(define-full-setter instance-index-set * instance-slots-offset - instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set) - - -(defknown %instance-set-conditional (instance index t t) t - (unsafe)) - -(define-vop (instance-set-conditional) - (:translate %instance-set-conditional) - (:args (object :scs (descriptor-reg) :to :eval) - (slot :scs (any-reg) :to :result) - (old-value :scs (descriptor-reg any-reg) :target eax) - (new-value :scs (descriptor-reg any-reg))) - (:arg-types instance positive-fixnum * *) - (:temporary (:sc descriptor-reg :offset eax-offset - :from (:argument 2) :to :result :target result) eax) - (:results (result :scs (descriptor-reg any-reg))) - ;(:guard (backend-featurep :i486)) - (: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)) - new-value) - (move result eax))) +(define-full-reffer instance-index-ref * + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %instance-ref) +(define-full-setter instance-index-set * + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %instance-set) +(define-full-compare-and-swap instance-compare-and-swap instance + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %instance-compare-and-swap) ;;;; code object frobbing @@ -491,15 +437,29 @@ (define-full-setter code-header-set * 0 other-pointer-lowtag (any-reg descriptor-reg) * code-header-set) - - ;;;; 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 + :index instance-length + :scale 4 + :disp (- (* (- instance-slots-offset n-words) + n-word-bytes) + instance-pointer-lowtag + (fixnumize (tn-value index))))))) + (define-vop (raw-instance-ref/word) (:translate %raw-instance-ref/word) (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate))) (:arg-types * tagged-num) (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (unsigned-reg))) @@ -507,21 +467,16 @@ (: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))))) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (inst mov value (make-ea-for-raw-slot object index tmp 1)))) (define-vop (raw-instance-set/word) (:translate %raw-instance-set/word) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg immediate)) (value :scs (unsigned-reg) :target result)) (:arg-types * tagged-num unsigned-num) (:temporary (:sc unsigned-reg) tmp) @@ -530,21 +485,16 @@ (: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) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (inst mov (make-ea-for-raw-slot object index tmp 1) 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))) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate))) (:arg-types * tagged-num) (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (single-reg))) @@ -552,21 +502,17 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 2) - (inst sub tmp index) + (when (sc-is index any-reg) + (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)))))) + (inst fld (make-ea-for-raw-slot object index tmp 1))))) (define-vop (raw-instance-set/single) (:translate %raw-instance-set/single) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg immediate)) (value :scs (single-reg) :target result)) (:arg-types * tagged-num single-float) (:temporary (:sc unsigned-reg) tmp) @@ -575,16 +521,12 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 2) - (inst sub tmp index) + (when (sc-is index any-reg) + (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))) + (inst fst (make-ea-for-raw-slot object index tmp 1)) (cond ((zerop (tn-offset value)) (unless (zerop (tn-offset result)) @@ -599,7 +541,7 @@ (define-vop (raw-instance-ref/double) (:translate %raw-instance-ref/double) (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate))) (:arg-types * tagged-num) (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (double-reg))) @@ -607,21 +549,17 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 2) - (inst sub tmp index) + (when (sc-is index any-reg) + (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)))))) + (inst fldd (make-ea-for-raw-slot object index tmp 2))))) (define-vop (raw-instance-set/double) (:translate %raw-instance-set/double) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg immediate)) (value :scs (double-reg) :target result)) (:arg-types * tagged-num double-float) (:temporary (:sc unsigned-reg) tmp) @@ -630,16 +568,12 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 2) - (inst sub tmp index) + (when (sc-is index any-reg) + (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))) + (inst fstd (make-ea-for-raw-slot object index tmp 2)) (cond ((zerop (tn-offset value)) (unless (zerop (tn-offset result)) @@ -655,7 +589,7 @@ (:translate %raw-instance-ref/complex-single) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg immediate))) (:arg-types * positive-fixnum) (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (complex-single-reg))) @@ -663,30 +597,21 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 2) - (inst sub tmp index) + (when (sc-is index any-reg) + (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))))) + (inst fld (make-ea-for-raw-slot object index tmp 2)))) (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))))))) + (inst fld (make-ea-for-raw-slot object index tmp 1)))))) (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)) + (index :scs (any-reg immediate)) (value :scs (complex-single-reg) :target result)) (:arg-types * positive-fixnum complex-single-float) (:temporary (:sc unsigned-reg) tmp) @@ -695,30 +620,21 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 2) - (inst sub tmp index) + (when (sc-is index any-reg) + (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))) + (inst fst (make-ea-for-raw-slot object index tmp 2)) (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))) + (inst fst (make-ea-for-raw-slot object index tmp 2)) (cond ((zerop (tn-offset result-real)) ;; The result is in ST0. (inst fst value-real)) @@ -730,12 +646,7 @@ (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))) + (inst fst (make-ea-for-raw-slot object index tmp 1)) (unless (location= value-imag result-imag) (inst fst result-imag)) (inst fxch value-imag)))) @@ -744,7 +655,7 @@ (:translate %raw-instance-ref/complex-double) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg immediate))) (:arg-types * positive-fixnum) (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (complex-double-reg))) @@ -752,30 +663,21 @@ (:generator 7 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 2) - (inst sub tmp index) + (when (sc-is index any-reg) + (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))))) + (inst fldd (make-ea-for-raw-slot object index tmp 4)))) (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))))))) + (inst fldd (make-ea-for-raw-slot object index tmp 2)))))) (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)) + (index :scs (any-reg immediate)) (value :scs (complex-double-reg) :target result)) (:arg-types * positive-fixnum complex-double-float) (:temporary (:sc unsigned-reg) tmp) @@ -784,30 +686,21 @@ (:generator 20 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 2) - (inst sub tmp index) + (when (sc-is index any-reg) + (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))) + (inst fstd (make-ea-for-raw-slot object index tmp 4)) (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))) + (inst fstd (make-ea-for-raw-slot object index tmp 4)) (cond ((zerop (tn-offset result-real)) ;; The result is in ST0. (inst fstd value-real)) @@ -819,12 +712,7 @@ (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))) + (inst fstd (make-ea-for-raw-slot object index tmp 2)) (unless (location= value-imag result-imag) (inst fstd result-imag)) (inst fxch value-imag))))