X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fcell.lisp;h=d89f989878ffd7eb030beeb7ebcd069acafe9dd8;hb=7deecae2d959173eda6a153d490c752c32050a9e;hp=c3cfb86ab9de748449ebfa175f9f372e2a4ad410;hpb=9f10bc102adce15a820027777a03e49a7b7623da;p=sbcl.git diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index c3cfb86..d89f989 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -23,89 +23,182 @@ (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 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) - base-char-widetag))))) - ;; 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) + (inst cmpxchg (make-ea :dword :base object + :disp (- (* offset n-word-bytes) lowtag)) + new :lock) + (move result eax))) ;;;; symbol hacking VOPs -;;; these next two cf the sparc version, by jrd. -;;; FIXME: Deref this ^ reference. - -;;; The compiler likes to be able to directly SET symbols. -(define-vop (set cell-set) - (: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))) +(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) - (:save-p :compute-only) - (:temporary (:sc descriptor-reg :from (:argument 0)) obj-temp)) + (: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 cmpxchg (make-ea :dword :base tls) new :fs) + (inst cmp eax no-tls-value-marker-widetag) + (inst jmp :ne check) + (move eax old)) + (inst cmpxchg (make-ea :dword :base symbol + :disp (- (* symbol-value-slot n-word-bytes) + other-pointer-lowtag)) + new :lock) + (emit-label check) + (move result eax) + (inst cmp result unbound-marker-widetag) + (inst jmp :e unbound)))) + +(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. -(define-vop (symbol-value) - (:translate symbol-value) +(define-vop (fast-symbol-global-value cell-ref) + (:variant symbol-value-slot other-pointer-lowtag) + (:policy :fast) + (:translate symbol-global-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) (:save-p :compute-only) (:generator 9 - (let ((err-lab (generate-error-code vop unbound-symbol-error object))) + (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)))) -(define-vop (fast-symbol-value cell-ref) - (: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-lowtag) - (:policy :fast) - (:translate fast-symbol-value-xadd) - (:arg-types * tagged-num)) +#!+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))))) + +#!-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 :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 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)))) +#!-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) + (:conditional :ne) (:generator 9 - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst cmp value unbound-marker-widetag) - (inst jmp (if not-p :e :ne) target))) + (inst cmp (make-ea-for-object-slot object symbol-value-slot + other-pointer-lowtag) + unbound-marker-widetag))) + (define-vop (symbol-hash) (:policy :fast-safe) @@ -123,7 +216,7 @@ ;;;; fdefinition (FDEFN) objects -(define-vop (fdefn-fun cell-ref) ; /pfw - alpha +(define-vop (fdefn-fun cell-ref) ; /pfw - alpha (:variant fdefn-fun-slot other-pointer-lowtag)) (define-vop (safe-fdefn-fun) @@ -134,26 +227,25 @@ (:generator 10 (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))) + (let ((err-lab (generate-error-code vop 'undefined-fun-error object))) (inst jmp :e err-lab)))) (define-vop (set-fdefn-fun) (:policy :fast-safe) (: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 (- 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 (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) @@ -166,8 +258,8 @@ (: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) - fdefn fdefn-raw-addr-slot other-pointer-lowtag) + (storew (make-fixup "undefined_tramp" :foreign) + fdefn fdefn-raw-addr-slot other-pointer-lowtag) (move result fdefn))) ;;;; binding and unbinding @@ -176,9 +268,44 @@ ;;; 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 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)))) + +#!-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*) @@ -189,6 +316,24 @@ (storew symbol bsp (- binding-symbol-slot binding-size)) (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 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)) + (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 @@ -197,14 +342,16 @@ (loadw value bsp (- binding-value-slot binding-size)) (storew value symbol symbol-value-slot other-pointer-lowtag) (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*))) + (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) @@ -212,17 +359,45 @@ (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-lowtag) + #!-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)) 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) - (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 @@ -238,9 +413,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)) @@ -267,23 +439,20 @@ (loadw res struct 0 instance-pointer-lowtag) (inst shr res n-widetag-bits))) -(define-vop (instance-ref slot-ref) - (:variant instance-slots-offset instance-pointer-lowtag) - (:policy :fast-safe) - (:translate %instance-ref) - (:arg-types instance (:constant index))) - -(define-vop (instance-set slot-set) - (:policy :fast-safe) - (:translate %instance-set) - (:variant instance-slots-offset instance-pointer-lowtag) - (:arg-types instance (:constant index) *)) +(define-full-reffer instance-index-ref * + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %instance-ref) -(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-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 @@ -292,3 +461,365 @@ (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) + (if (integerp instance-length) + ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length + ;; at compile time. + (make-ea :dword + :base object + :disp (- (* (- instance-length instance-slots-offset index (1- n-words)) + n-word-bytes) + instance-pointer-lowtag)) + (flet ((make-ea-using-value (value) + (make-ea :dword :base object + :index instance-length + :scale 4 + :disp (- (* (- instance-slots-offset n-words) + n-word-bytes) + instance-pointer-lowtag + (* value n-word-bytes))))) + (if (typep index 'tn) + (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-using-value (tn-value index)))) + (make-ea-using-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 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 n-fixnum-tag-bits) + (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 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 n-fixnum-tag-bits) + (inst sub tmp index)) + (inst mov (make-ea-for-raw-slot object index tmp 1) value) + (move result value))) + +(define-vop (raw-instance-init/word) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg))) + (:arg-types * unsigned-num) + (:info instance-length index) + (:generator 5 + (inst mov (make-ea-for-raw-slot object index instance-length 1) value))) + +(define-vop (raw-instance-atomic-incf/word) + (:translate %raw-instance-atomic-incf/word) + (: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) + (: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 n-fixnum-tag-bits) + (inst sub tmp index)) + (inst xadd (make-ea-for-raw-slot object index tmp 1) diff :lock) + (move result diff))) + +(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 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (when (sc-is index any-reg) + (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))))) + +(define-vop (raw-instance-set/single) + (:translate %raw-instance-set/single) + (:policy :fast-safe) + (: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 n-fixnum-tag-bits) + (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-init/single) + (:args (object :scs (descriptor-reg)) + (value :scs (single-reg))) + (:arg-types * single-float) + (:info instance-length index) + (:generator 5 + (with-tn@fp-top (value) + (inst fst (make-ea-for-raw-slot object index instance-length 1))))) + +(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 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))))) + +(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 n-fixnum-tag-bits) + (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-init/double) + (:args (object :scs (descriptor-reg)) + (value :scs (double-reg))) + (:arg-types * double-float) + (:info instance-length index) + (:generator 5 + (with-tn@fp-top (value) + (inst fstd (make-ea-for-raw-slot object index instance-length 2))))) + +(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 n-fixnum-tag-bits) + (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 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))) + (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-init/complex-single) + (:args (object :scs (descriptor-reg)) + (value :scs (complex-single-reg))) + (:arg-types * complex-single-float) + (:info instance-length index) + (:generator 5 + (let ((value-real (complex-single-reg-real-tn value))) + (with-tn@fp-top (value-real) + (inst fst (make-ea-for-raw-slot object index instance-length 2)))) + (let ((value-imag (complex-single-reg-imag-tn value))) + (with-tn@fp-top (value-imag) + (inst fst (make-ea-for-raw-slot object index instance-length 1)))))) + +(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 n-fixnum-tag-bits) + (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 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))) + (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)))) + +(define-vop (raw-instance-init/complex-double) + (:args (object :scs (descriptor-reg)) + (value :scs (complex-double-reg))) + (:arg-types * complex-double-float) + (:info instance-length index) + (:generator 20 + (let ((value-real (complex-double-reg-real-tn value))) + (with-tn@fp-top (value-real) + (inst fstd (make-ea-for-raw-slot object index instance-length 4)))) + (let ((value-imag (complex-double-reg-imag-tn value))) + (with-tn@fp-top (value-imag) + (inst fstd (make-ea-for-raw-slot object index instance-length 2))))))