X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fcell.lisp;h=241d434d012eddabd09ab28302e296c4dfdf71d4;hb=a6b91f356da1b5ae2987f79db9bd137970512959;hp=336b5dc8d66635ba8d05f630e98966a9b0bf061c;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index 336b5dc..241d434 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -10,9 +10,6 @@ ;;;; files for more information. (in-package "SB!VM") - -(file-comment - "$Header$") ;;;; data object ref/set stuff @@ -26,53 +23,146 @@ (define-vop (set-slot) (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg immediate))) + (value :scs (descriptor-reg any-reg immediate))) (:info name offset lowtag) (: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 word-bytes) lowtag)) - (fixnumize val))) - (symbol - (inst mov - (make-ea :dword :base object - :disp (- (* offset word-bytes) lowtag)) - (+ *nil-value* (static-symbol-offset val)))) - (character - (inst mov - (make-ea :dword :base object - :disp (- (* offset word-bytes) lowtag)) - (logior (ash (char-code val) type-bits) - base-char-type))))) - ;; Else, value not immediate. - (storew value object offset lowtag)))) + (storew (encode-value-if-immediate value) object offset lowtag))) + +(define-vop (compare-and-swap-slot) + (:args (object :scs (descriptor-reg) :to :eval) + (old :scs (descriptor-reg any-reg) :target eax) + (new :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg :offset eax-offset + :from (:argument 1) :to :result :target result) + eax) + (:info name offset lowtag) + (:ignore name) + (: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) + (move result eax))) ;;;; symbol hacking VOPs +(define-vop (%compare-and-swap-symbol-value) + (:translate %compare-and-swap-symbol-value) + (:args (symbol :scs (descriptor-reg) :to (:result 1)) + (old :scs (descriptor-reg any-reg) :target eax) + (new :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg :offset eax-offset) eax) + #!+sb-thread + (:temporary (:sc descriptor-reg) tls) + (:results (result :scs (descriptor-reg any-reg))) + (:policy :fast-safe) + (:vop-var vop) + (:generator 15 + ;; 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)) + (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 cmp eax no-tls-value-marker-widetag) + (inst jmp :ne check) + (move eax old) + (inst lock)) + (inst cmpxchg (make-ea :dword :base symbol + :disp (- (* symbol-value-slot n-word-bytes) + other-pointer-lowtag)) + new) + (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) - (:variant symbol-value-slot other-pointer-type)) + (:variant symbol-value-slot other-pointer-lowtag)) -;;; Do a cell ref with an error check for being unbound. -(define-vop (checked-cell-ref) - (:args (object :scs (descriptor-reg) :target obj-temp)) - (:results (value :scs (descriptor-reg any-reg))) +;;; 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) - (: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. + (: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 + (: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)))) + +#!-sb-thread (define-vop (symbol-value) (:translate symbol-value) (:policy :fast-safe) @@ -81,35 +171,69 @@ (:vop-var vop) (:save-p :compute-only) (:generator 9 - (let ((err-lab (generate-error-code vop unbound-symbol-error object))) - (loadw value object symbol-value-slot other-pointer-type) - (inst cmp value unbound-marker-type) + (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)))) +#!-sb-thread (define-vop (fast-symbol-value cell-ref) - (:variant symbol-value-slot other-pointer-type) + (:variant symbol-value-slot other-pointer-lowtag) (:policy :fast) (:translate symbol-value)) -(defknown fast-symbol-value-xadd (symbol fixnum) fixnum ()) -(define-vop (fast-symbol-value-xadd cell-xadd) - (:variant symbol-value-slot other-pointer-type) +(defknown locked-symbol-global-value-add (symbol fixnum) fixnum ()) + +(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-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-for-object-slot object symbol-value-slot + other-pointer-lowtag) + value))) +#!+sb-thread +(define-vop (boundp) + (:translate boundp) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (: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 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)))) + +#!-sb-thread (define-vop (boundp) (:translate boundp) (:policy :fast-safe) (: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-type) - (inst cmp value unbound-marker-type) + (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))) + (define-vop (symbol-hash) (:policy :fast-safe) (:translate symbol-hash) @@ -117,56 +241,48 @@ (:results (res :scs (any-reg))) (:result-types positive-fixnum) (:generator 2 - ;; The symbol-hash slot of NIL holds NIL because it is also the cdr slot, - ;; so we have to strip off the two low bits to make sure it is a fixnum. - ;; - ;; FIXME: Is this still true? It seems to me from my reading of - ;; the DEFINE-PRIMITIVE-OBJECT in objdef.lisp that the symbol-hash - ;; is the second slot, and offset 0 = tags and stuff (and CAR slot in - ;; a CONS), offset 1 = value slot (and CDR slot in a CONS), and - ;; offset 2 = hash slot. - (loadw res symbol symbol-hash-slot other-pointer-type) + ;; The symbol-hash slot of NIL holds NIL because it is also the + ;; cdr slot, so we have to strip off the two low bits to make sure + ;; it is a fixnum. The lowtag selection magic that is required to + ;; ensure this is explained in the comment in objdef.lisp + (loadw res symbol symbol-hash-slot other-pointer-lowtag) (inst and res (lognot #b11)))) -;;;; fdefinition (fdefn) objects +;;;; fdefinition (FDEFN) objects -(define-vop (fdefn-function cell-ref) ; /pfw - alpha - (:variant fdefn-function-slot other-pointer-type)) +(define-vop (fdefn-fun cell-ref) ; /pfw - alpha + (:variant fdefn-fun-slot other-pointer-lowtag)) -(define-vop (safe-fdefn-function) +(define-vop (safe-fdefn-fun) (:args (object :scs (descriptor-reg) :to (:result 1))) (:results (value :scs (descriptor-reg any-reg))) (:vop-var vop) (:save-p :compute-only) (:generator 10 - (loadw value object fdefn-function-slot other-pointer-type) - (inst cmp value *nil-value*) - ;; FIXME: UNDEFINED-SYMBOL-ERROR seems to actually be for symbols with no - ;; function value, not, as the name might suggest, symbols with no ordinary - ;; value. Perhaps the name could be made more mnemonic? - (let ((err-lab (generate-error-code vop undefined-symbol-error object))) + (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))) (inst jmp :e err-lab)))) -(define-vop (set-fdefn-function) +(define-vop (set-fdefn-fun) (:policy :fast-safe) - (:translate (setf fdefn-function)) + (:translate (setf fdefn-fun)) (:args (function :scs (descriptor-reg) :target result) - (fdefn :scs (descriptor-reg))) + (fdefn :scs (descriptor-reg))) (:temporary (:sc unsigned-reg) raw) (:temporary (:sc byte-reg) type) (:results (result :scs (descriptor-reg))) (:generator 38 - (load-type type function (- function-pointer-type)) + (load-type type function (- fun-pointer-lowtag)) (inst lea raw - (make-ea :byte :base function - :disp (- (* function-code-offset word-bytes) - function-pointer-type))) - (inst cmp type function-header-type) + (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 (extern-alien-name "closure_tramp") :foreign)) + (inst lea raw (make-fixup "closure_tramp" :foreign)) NORMAL-FN - (storew function fdefn fdefn-function-slot other-pointer-type) - (storew raw fdefn fdefn-raw-addr-slot other-pointer-type) + (storew function fdefn fdefn-fun-slot other-pointer-lowtag) + (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag) (move result function))) (define-vop (fdefn-makunbound) @@ -175,9 +291,9 @@ (:args (fdefn :scs (descriptor-reg) :target result)) (:results (result :scs (descriptor-reg))) (:generator 38 - (storew *nil-value* fdefn fdefn-function-slot other-pointer-type) - (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign) - fdefn fdefn-raw-addr-slot other-pointer-type) + (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag) + (storew (make-fixup "undefined_tramp" :foreign) + fdefn fdefn-raw-addr-slot other-pointer-lowtag) (move result fdefn))) ;;;; binding and unbinding @@ -186,35 +302,93 @@ ;;; 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 unsigned-reg) tls-index bsp) + (: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 fs-segment-prefix) + (inst push (make-ea :dword :base tls-index)) + (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)))) + +#!-sb-thread (define-vop (bind) (:args (val :scs (any-reg descriptor-reg)) - (symbol :scs (descriptor-reg))) + (symbol :scs (descriptor-reg))) (:temporary (:sc unsigned-reg) temp bsp) (:generator 5 (load-symbol-value bsp *binding-stack-pointer*) - (loadw temp symbol symbol-value-slot other-pointer-type) - (inst add bsp (* binding-size word-bytes)) + (loadw temp symbol symbol-value-slot other-pointer-lowtag) + (inst add bsp (* binding-size n-word-bytes)) (store-symbol-value bsp *binding-stack-pointer*) (storew temp bsp (- binding-value-slot binding-size)) (storew symbol bsp (- binding-symbol-slot binding-size)) - (storew val symbol symbol-value-slot other-pointer-type))) + (storew val symbol symbol-value-slot other-pointer-lowtag))) + +#!+sb-thread +(define-vop (unbind) + (:temporary (:sc unsigned-reg) temp bsp tls-index) + (: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) + ;; 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) + ;; 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)) + (store-binding-stack-pointer bsp))) +#!-sb-thread (define-vop (unbind) (:temporary (:sc unsigned-reg) symbol value bsp) (:generator 0 (load-symbol-value bsp *binding-stack-pointer*) (loadw symbol bsp (- binding-symbol-slot binding-size)) (loadw value bsp (- binding-value-slot binding-size)) - (storew value symbol symbol-value-slot other-pointer-type) + (storew value symbol symbol-value-slot other-pointer-lowtag) (storew 0 bsp (- binding-symbol-slot binding-size)) - (inst sub bsp (* binding-size word-bytes)) + (storew 0 bsp (- binding-value-slot binding-size)) + (inst sub bsp (* binding-size n-word-bytes)) (store-symbol-value bsp *binding-stack-pointer*))) + (define-vop (unbind-to-here) (:args (where :scs (descriptor-reg any-reg))) - (:temporary (:sc unsigned-reg) symbol value bsp) + (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index) (:generator 0 - (load-symbol-value bsp *binding-stack-pointer*) + (load-binding-stack-pointer bsp) (inst cmp where bsp) (inst jmp :e done) @@ -222,48 +396,74 @@ (loadw symbol bsp (- binding-symbol-slot binding-size)) (inst or 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)) - (storew value symbol symbol-value-slot other-pointer-type) + #!-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 fs-segment-prefix) + #!+sb-thread (inst mov (make-ea :dword :base tls-index) value) (storew 0 bsp (- binding-symbol-slot binding-size)) SKIP - (inst sub bsp (* binding-size word-bytes)) + (storew 0 bsp (- binding-value-slot binding-size)) + (inst sub bsp (* binding-size n-word-bytes)) (inst cmp where bsp) (inst jmp :ne loop) - (store-symbol-value bsp *binding-stack-pointer*) + (store-binding-stack-pointer bsp) DONE)) + +(define-vop (bind-sentinel) + (:temporary (:sc unsigned-reg) bsp) + (:generator 1 + (load-binding-stack-pointer bsp) + (inst add bsp (* binding-size n-word-bytes)) + (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size)) + (storew ebp-tn bsp (- binding-value-slot binding-size)) + (store-binding-stack-pointer bsp))) + +(define-vop (unbind-sentinel) + (:temporary (:sc unsigned-reg) bsp) + (:generator 1 + (load-binding-stack-pointer bsp) + (storew 0 bsp (- binding-value-slot binding-size)) + (storew 0 bsp (- binding-symbol-slot binding-size)) + (inst sub bsp (* binding-size n-word-bytes)) + (store-binding-stack-pointer bsp))) + + ;;;; closure indexing (define-full-reffer closure-index-ref * - closure-info-offset function-pointer-type + closure-info-offset fun-pointer-lowtag (any-reg descriptor-reg) * %closure-index-ref) (define-full-setter set-funcallable-instance-info * - funcallable-instance-info-offset function-pointer-type + funcallable-instance-info-offset fun-pointer-lowtag (any-reg descriptor-reg) * %set-funcallable-instance-info) (define-full-reffer funcallable-instance-info * - funcallable-instance-info-offset function-pointer-type + 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 function-pointer-type)) - (define-vop (closure-ref slot-ref) - (:variant closure-info-offset function-pointer-type)) + (:variant closure-info-offset fun-pointer-lowtag)) (define-vop (closure-init slot-set) - (:variant closure-info-offset function-pointer-type)) + (:variant closure-info-offset fun-pointer-lowtag)) ;;;; value cell hackery (define-vop (value-cell-ref cell-ref) - (:variant value-cell-value-slot other-pointer-type)) + (:variant value-cell-value-slot other-pointer-lowtag)) (define-vop (value-cell-set cell-set) - (:variant value-cell-value-slot other-pointer-type)) + (:variant value-cell-value-slot other-pointer-lowtag)) ;;;; structure hackery @@ -274,68 +474,307 @@ (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 4 - (loadw res struct 0 instance-pointer-type) - (inst shr res type-bits))) + (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) + +(define-full-compare-and-swap %compare-and-swap-instance-ref instance + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %compare-and-swap-instance-ref) + +;;;; code object frobbing -(define-vop (instance-ref slot-ref) - (:variant instance-slots-offset instance-pointer-type) - (:policy :fast-safe) - (:translate %instance-ref) - (:arg-types instance (:constant index))) +(define-full-reffer code-header-ref * 0 other-pointer-lowtag + (any-reg descriptor-reg) * code-header-ref) -(define-vop (instance-set slot-set) +(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) - (:translate %instance-set) - (:variant instance-slots-offset instance-pointer-type) - (:arg-types instance (:constant index) *)) - -(define-full-reffer instance-index-ref * instance-slots-offset - instance-pointer-type (any-reg descriptor-reg) * %instance-ref) - -(define-full-setter instance-index-set * instance-slots-offset - instance-pointer-type (any-reg descriptor-reg) * %instance-set) - -(defknown sb!kernel::%instance-set-conditional (instance index t t) t - (unsafe)) - -(define-vop (instance-set-conditional-c slot-set-conditional) + (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate))) + (: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) + (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) - (:translate sb!kernel::%instance-set-conditional) - (:variant instance-slots-offset instance-pointer-type) - (:arg-types instance (:constant index) * *)) - -(define-vop (instance-set-conditional) - (:translate sb!kernel::%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) :target temp)) - (:arg-types instance positive-fixnum * *) - (:temporary (:sc descriptor-reg :offset eax-offset - :from (:argument 1) :to :result :target result) eax) - (:temporary (:sc descriptor-reg :from (:argument 2) :to :result) temp) - (:results (result :scs (descriptor-reg))) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (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) + (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 immediate))) + (:arg-types * tagged-num) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (single-reg))) + (:result-types single-float) (:generator 5 - (move eax old-value) - (move temp new-value) - (inst cmpxchg (make-ea :dword :base object :index slot :scale 1 - :disp (- (* instance-slots-offset word-bytes) - instance-pointer-type)) - temp) - (move result eax))) - -(defknown %instance-xadd (instance index fixnum) fixnum ()) -(define-vop (instance-xadd-c slot-xadd) + (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)) + (with-empty-tn@fp-top(value) + (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) - (:translate %instance-xadd) - (:variant instance-slots-offset instance-pointer-type) - (:arg-types instance (:constant index) tagged-num)) - -;;;; code object frobbing - -(define-full-reffer code-header-ref * 0 other-pointer-type - (any-reg descriptor-reg) * code-header-ref) - -(define-full-setter code-header-set * 0 other-pointer-type - (any-reg descriptor-reg) * code-header-set) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg immediate)) + (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) + (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-for-raw-slot object index tmp 1)) + (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 immediate))) + (: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) + (when (sc-is index any-reg) + (inst shl tmp 2) + (inst sub tmp index)) + (with-empty-tn@fp-top(value) + (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 immediate)) + (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) + (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-for-raw-slot object index tmp 2)) + (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 immediate))) + (: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) + (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-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-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 immediate)) + (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) + (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-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-for-raw-slot object index tmp 2)) + (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-for-raw-slot object index tmp 1)) + (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 immediate))) + (: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) + (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-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-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 immediate)) + (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) + (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-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-for-raw-slot object index tmp 4)) + (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-for-raw-slot object index tmp 2)) + (unless (location= value-imag result-imag) + (inst fstd result-imag)) + (inst fxch value-imag))))