X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fcell.lisp;h=f20d3fba21d3a0f8d6c5132dbdd0845a5d336dd1;hb=b83353d9f998e5c0e34604b5593df70c66d2c510;hp=4be948483ee77bb3c4712df9d53f555f6e2799ad;hpb=f3f677703e37f5a335b3be7fa64f7748ad969517;p=sbcl.git diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 4be9484..f20d3fb 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -19,201 +19,212 @@ (:ignore name) (:results (result :scs (descriptor-reg any-reg))) (:generator 1 - (loadw result object offset lowtag))) + (loadw result object offset lowtag))) (define-vop (set-slot) (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg immediate))) + (value :scs (descriptor-reg any-reg immediate))) (:temporary (:sc descriptor-reg) temp) (:info name offset lowtag) (:ignore name) (:results) (:generator 1 (if (sc-is value immediate) - (let ((val (tn-value value))) - (move-immediate (make-ea :qword - :base object - :disp (- (* offset n-word-bytes) - lowtag)) - (etypecase val - (integer - (fixnumize val)) - (symbol - (+ nil-value (static-symbol-offset val))) - (character - (logior (ash (char-code val) n-widetag-bits) - character-widetag))) - temp)) - ;; Else, value not immediate. - (storew value object offset lowtag)))) + (let ((val (tn-value value))) + (move-immediate (make-ea :qword + :base object + :disp (- (* offset n-word-bytes) + lowtag)) + (etypecase val + (integer + (fixnumize val)) + (symbol + (+ nil-value (static-symbol-offset val))) + (character + (logior (ash (char-code val) n-widetag-bits) + character-widetag))) + temp)) + ;; Else, value not immediate. + (storew value object offset lowtag)))) + +(define-vop (init-slot set-slot)) + +(define-vop (compare-and-swap-slot) + (:args (object :scs (descriptor-reg) :to :eval) + (old :scs (descriptor-reg any-reg) :target rax) + (new :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg :offset rax-offset + :from (:argument 1) :to :result :target result) + rax) + (:info name offset lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg any-reg))) + (:generator 5 + (move rax old) + (inst cmpxchg (make-ea :qword :base object + :disp (- (* offset n-word-bytes) lowtag)) + new :lock) + (move result rax))) - - ;;;; 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. -#!+sb-thread -(define-vop (set) - (:args (symbol :scs (descriptor-reg)) - (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 rax) + (new :scs (descriptor-reg any-reg))) + (:temporary (:sc descriptor-reg :offset rax-offset) rax) + #!+sb-thread (: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 or tls tls) - (inst jmp :z global-val) - (inst fs-segment-prefix) - (inst cmp (make-ea :dword :scale 1 :index tls) unbound-marker-widetag) - (inst jmp :z global-val) - (inst fs-segment-prefix) - (inst mov (make-ea :dword :scale 1 :index 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-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 -(define-vop (symbol-value) - (:translate symbol-value) + (:results (result :scs (descriptor-reg any-reg))) (: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* ((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 :index value :scale 1)) - (inst cmp value unbound-marker-widetag) - (inst jmp :ne ret-lab) - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst cmp value unbound-marker-widetag) - (inst jmp :e err-lab) - (emit-label ret-lab)))) + (:generator 15 + ;; This code has two 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 rax old) + #!+sb-thread + (progn + (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) + ;; Thread-local area, no LOCK needed. + (inst cmpxchg (make-ea :qword :base thread-base-tn + :index tls :scale 1) + new) + (inst cmp rax no-tls-value-marker-widetag) + (inst jmp :ne check) + (move rax old)) + (inst cmpxchg (make-ea :qword :base symbol + :disp (- (* symbol-value-slot n-word-bytes) + other-pointer-lowtag) + :scale 1) + new :lock) + (emit-label check) + (move result rax) + (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)) -#!+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 +(define-vop (fast-symbol-global-value cell-ref) + (:variant symbol-value-slot other-pointer-lowtag) (: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 :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)))) + (:translate symbol-global-value)) -#!-sb-thread -(define-vop (symbol-value) - (:translate symbol-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)))) -#!-sb-thread -(define-vop (fast-symbol-value cell-ref) - (:variant symbol-value-slot other-pointer-lowtag) - (:policy :fast) - (:translate symbol-value)) - -(defknown locked-symbol-global-value-add (symbol fixnum) fixnum ()) +#!+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 :qword :base thread-base-tn :scale 1 :index tls) + no-tls-value-marker-widetag) + (inst jmp :z global-val) + (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls) + value) + (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 :qword :base thread-base-tn + :index value :scale 1)) + (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 :qword :base thread-base-tn :index value :scale 1)) + (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))))) -(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 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 +(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) - (:info target not-p) + (:conditional :ne) (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value) (:generator 9 - (if not-p - (let ((not-target (gen-label))) - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst cmp value unbound-marker-widetag) - (inst jmp :ne not-target) - (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst fs-segment-prefix) - (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag) - (inst jmp :e target) - (emit-label not-target)) - (progn - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst cmp value unbound-marker-widetag) - (inst jmp :ne target) - (loadw value object symbol-tls-index-slot other-pointer-lowtag) - (inst fs-segment-prefix) - (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag) - (inst jmp :ne target))))) + (let ((check-unbound-label (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst mov value + (make-ea :qword :base thread-base-tn :index value :scale 1)) + (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) @@ -228,11 +239,11 @@ ;; 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 #b111)))) + (inst and res (lognot fixnum-tag-mask)))) ;;;; 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) @@ -243,26 +254,26 @@ (: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) + (:temporary (:sc unsigned-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))) - (inst cmp type simple-fun-header-widetag) + (make-ea :byte :base function + :disp (- (* simple-fun-code-offset n-word-bytes) + fun-pointer-lowtag))) + (inst cmp (reg-in-size type :byte) simple-fun-header-widetag) (inst jmp :e NORMAL-FUN) - (inst lea raw (make-fixup "closure_tramp" :foreign)) + (inst mov raw (make-fixup "closure_tramp" :foreign)) NORMAL-FUN (storew function fdefn fdefn-fun-slot other-pointer-lowtag) (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag) @@ -276,7 +287,7 @@ (:generator 38 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag) (storew (make-fixup "undefined_tramp" :foreign) - fdefn fdefn-raw-addr-slot other-pointer-lowtag) + fdefn fdefn-raw-addr-slot other-pointer-lowtag) (move result fdefn))) ;;;; binding and unbinding @@ -284,34 +295,44 @@ ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and ;;; the symbol on the binding stack and stuff the new value into the ;;; symbol. +;;; See the "Chapter 9: Specials" of the SBCL Internals Manual. #!+sb-thread (define-vop (bind) (:args (val :scs (any-reg descriptor-reg)) - (symbol :scs (descriptor-reg))) - (:temporary (:sc unsigned-reg) tls-index temp bsp) - (:generator 5 - (let ((tls-index-valid (gen-label))) - (load-tl-symbol-value bsp *binding-stack-pointer*) - (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) - (inst add bsp (* binding-size n-word-bytes)) - (store-tl-symbol-value bsp *binding-stack-pointer* temp) - - (inst or tls-index tls-index) - (inst jmp :ne tls-index-valid) - ;; allocate a new tls-index - (load-symbol-value tls-index *free-tls-index*) - (inst add tls-index 4) ;XXX surely we can do this more - (store-symbol-value tls-index *free-tls-index*) ;succintly - (inst sub tls-index 4) - (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag) - (emit-label tls-index-valid) - (inst fs-segment-prefix) - (inst mov temp (make-ea :dword :scale 1 :index 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)))) + (symbol :scs (descriptor-reg) :target tmp + :to :load)) + (:temporary (:sc unsigned-reg) tls-index bsp tmp) + (:generator 10 + (load-binding-stack-pointer bsp) + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (inst add bsp (* binding-size n-word-bytes)) + (store-binding-stack-pointer bsp) + (inst test tls-index tls-index) + (inst jmp :ne TLS-INDEX-VALID) + (inst mov tls-index symbol) + (inst mov tmp + (make-fixup (ecase (tn-offset tls-index) + (#.rax-offset 'alloc-tls-index-in-rax) + (#.rcx-offset 'alloc-tls-index-in-rcx) + (#.rdx-offset 'alloc-tls-index-in-rdx) + (#.rbx-offset 'alloc-tls-index-in-rbx) + (#.rsi-offset 'alloc-tls-index-in-rsi) + (#.rdi-offset 'alloc-tls-index-in-rdi) + (#.r8-offset 'alloc-tls-index-in-r8) + (#.r9-offset 'alloc-tls-index-in-r9) + (#.r10-offset 'alloc-tls-index-in-r10) + (#.r12-offset 'alloc-tls-index-in-r12) + (#.r13-offset 'alloc-tls-index-in-r13) + (#.r14-offset 'alloc-tls-index-in-r14) + (#.r15-offset 'alloc-tls-index-in-r15)) + :assembly-routine)) + (inst call tmp) + TLS-INDEX-VALID + (inst mov tmp (make-ea :qword :base thread-base-tn :index tls-index)) + (storew tmp bsp (- binding-value-slot binding-size)) + (storew tls-index bsp (- binding-symbol-slot binding-size)) + (inst mov (make-ea :qword :base thread-base-tn :index tls-index) val))) #!-sb-thread (define-vop (bind) @@ -327,24 +348,24 @@ (storew symbol bsp (- binding-symbol-slot binding-size)) (storew val symbol symbol-value-slot other-pointer-lowtag))) - #!+sb-thread (define-vop (unbind) - ;; four temporaries? - (:temporary (:sc unsigned-reg) symbol value bsp tls-index) + (:temporary (:sc unsigned-reg) temp bsp tls-index) (:generator 0 - (load-tl-symbol-value bsp *binding-stack-pointer*) - (loadw symbol bsp (- binding-symbol-slot binding-size)) - (loadw value bsp (- binding-value-slot binding-size)) - - (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) - - (storew 0 bsp (- binding-symbol-slot binding-size)) + (load-binding-stack-pointer bsp) (inst sub bsp (* binding-size n-word-bytes)) - ;; we're done with value, so we can use it as a temp here - (store-tl-symbol-value bsp *binding-stack-pointer* value))) + ;; Load TLS-INDEX of the SYMBOL from stack + (loadw tls-index bsp binding-symbol-slot) + ;; Load VALUE from stack, then restore it to the TLS area. + (loadw temp bsp binding-value-slot) + (inst mov (make-ea :qword :base thread-base-tn :index tls-index) + temp) + ;; Zero out the stack. + (zeroize temp) + + (storew temp bsp binding-symbol-slot) + (storew temp bsp binding-value-slot) + (store-binding-stack-pointer bsp))) #!-sb-thread (define-vop (unbind) @@ -355,39 +376,62 @@ (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 #!+sb-thread tls-index) + (:temporary (:sc unsigned-reg) symbol value bsp zero) (:generator 0 - (load-tl-symbol-value bsp *binding-stack-pointer*) + (load-binding-stack-pointer bsp) (inst cmp where bsp) (inst jmp :e DONE) - + (zeroize zero) LOOP - (loadw symbol bsp (- binding-symbol-slot binding-size)) - (inst or symbol symbol) + (inst sub bsp (* binding-size n-word-bytes)) + ;; on sb-thread symbol is actually a tls-index + (loadw symbol bsp binding-symbol-slot) + (inst test symbol symbol) (inst jmp :z SKIP) - (loadw value bsp (- binding-value-slot binding-size)) - #!-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 :scale 1 :index tls-index) value) - (storew 0 bsp (- binding-symbol-slot binding-size)) + ;; 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) + #!-sb-thread + (storew value symbol symbol-value-slot other-pointer-lowtag) + #!+sb-thread + (inst mov (make-ea :qword :base thread-base-tn :index symbol) + value) + (storew zero bsp binding-symbol-slot) SKIP - (inst sub bsp (* binding-size n-word-bytes)) + (storew zero bsp binding-value-slot) + (inst cmp where bsp) (inst jmp :ne LOOP) - ;; we're done with value, so can use it as a temporary - (store-tl-symbol-value bsp *binding-stack-pointer* value) + (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 rbp-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))) + @@ -405,14 +449,17 @@ 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)) (define-vop (closure-init slot-set) (:variant closure-info-offset fun-pointer-lowtag)) + +(define-vop (closure-init-from-fp) + (:args (object :scs (descriptor-reg))) + (:info offset) + (:generator 4 + (storew rbp-tn object (+ closure-info-offset offset) fun-pointer-lowtag))) ;;;; value cell hackery @@ -434,50 +481,16 @@ (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-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-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 @@ -486,11 +499,34 @@ (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 instance-length + &key (index nil) (adjustment 0) (scale 1)) + (if (integerp instance-length) + ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length + ;; at compile time. + (make-ea :qword + :base object + :disp (+ (* (- instance-length instance-slots-offset index) + n-word-bytes) + (- instance-pointer-lowtag) + adjustment)) + (etypecase index + (null + (make-ea :qword :base object :index instance-length :scale scale + :disp (+ (* (1- instance-slots-offset) n-word-bytes) + (- instance-pointer-lowtag) + adjustment))) + (integer + (make-ea :qword :base object :index instance-length + :scale 8 + :disp (+ (* (1- instance-slots-offset) n-word-bytes) + (- instance-pointer-lowtag) + adjustment + (* index (- n-word-bytes)))))))) + (define-vop (raw-instance-ref/word) (:translate %raw-instance-ref/word) (:policy :fast-safe) @@ -502,22 +538,32 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (inst mov - value - (make-ea :qword - :base object - :index tmp - :disp (- (* (1- instance-slots-offset) n-word-bytes) - instance-pointer-lowtag))))) + (inst mov value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) + +(define-vop (raw-instance-ref-c/word) + (:translate %raw-instance-ref/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset))) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst mov value (make-ea-for-raw-slot object tmp :index index)))) (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)) + (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))) @@ -525,22 +571,62 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (inst mov - (make-ea :qword - :base object - :index tmp - :disp (- (* (1- instance-slots-offset) n-word-bytes) - instance-pointer-lowtag)) - value) + (inst mov (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value) + (move result value))) + +(define-vop (raw-instance-set-c/word) + (:translate %raw-instance-set/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg) :target result)) + (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset)) + unsigned-num) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst mov (make-ea-for-raw-slot object tmp :index index) 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 4 + (inst mov (make-ea-for-raw-slot object instance-length :index index) value))) + +(define-vop (raw-instance-atomic-incf-c/word) + (:translate %raw-instance-atomic-incf/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (diff :scs (unsigned-reg) :target result)) + (:arg-types * (:constant (load/store-index #.n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset)) + unsigned-num) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst xadd (make-ea-for-raw-slot object tmp :index index) 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))) + (index :scs (any-reg))) (:arg-types * positive-fixnum) (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (single-reg))) @@ -548,22 +634,32 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (inst movss - value - (make-ea :dword - :base object - :index tmp - :disp (- (* (1- instance-slots-offset) n-word-bytes) - instance-pointer-lowtag))))) + (inst movss value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) + +(define-vop (raw-instance-ref-c/single) + (:translate %raw-instance-ref/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset))) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (single-reg))) + (:result-types single-float) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst movss value (make-ea-for-raw-slot object tmp :index index)))) (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)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) (:arg-types * positive-fixnum single-float) (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (single-reg))) @@ -571,23 +667,43 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (inst movss - (make-ea :dword - :base object - :index tmp - :disp (- (* (1- instance-slots-offset) n-word-bytes) - instance-pointer-lowtag)) - value) - (unless (location= result value) - (inst movss result value)))) + (inst movss (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value) + (move result value))) + +(define-vop (raw-instance-set-c/single) + (:translate %raw-instance-set/single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (single-reg) :target result)) + (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset)) + single-float) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst movss (make-ea-for-raw-slot object tmp :index index) value) + (move result 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 4 + (inst movss (make-ea-for-raw-slot object instance-length :index index) value))) (define-vop (raw-instance-ref/double) (:translate %raw-instance-ref/double) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types * positive-fixnum) (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (double-reg))) @@ -595,22 +711,32 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (inst movsd - value - (make-ea :dword - :base object - :index tmp - :disp (- (* (1- instance-slots-offset) n-word-bytes) - instance-pointer-lowtag))))) + (inst movsd value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) + +(define-vop (raw-instance-ref-c/double) + (:translate %raw-instance-ref/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset))) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (double-reg))) + (:result-types double-float) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst movsd value (make-ea-for-raw-slot object tmp :index index)))) (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)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) (:arg-types * positive-fixnum double-float) (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (double-reg))) @@ -618,23 +744,43 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (inst movsd - (make-ea :dword - :base object - :index tmp - :disp (- (* (1- instance-slots-offset) n-word-bytes) - instance-pointer-lowtag)) - value) - (unless (location= result value) - (inst movsd result value)))) + (inst movsd (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value) + (move result value))) + +(define-vop (raw-instance-set-c/double) + (:translate %raw-instance-set/double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (double-reg) :target result)) + (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset)) + double-float) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst movsd (make-ea-for-raw-slot object tmp :index index) value) + (move result 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 4 + (inst movsd (make-ea-for-raw-slot object instance-length :index index) 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))) + (index :scs (any-reg))) (:arg-types * positive-fixnum) (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (complex-single-reg))) @@ -642,32 +788,32 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (let ((real-tn (complex-single-reg-real-tn value))) - (inst movss - real-tn - (make-ea :dword - :base object - :index tmp - :disp (- (* (1- instance-slots-offset) n-word-bytes) - instance-pointer-lowtag)))) - (let ((imag-tn (complex-single-reg-imag-tn value))) - (inst movss - imag-tn - (make-ea :dword - :base object - :index tmp - :disp (+ (* (1- instance-slots-offset) n-word-bytes) - 4 - (- instance-pointer-lowtag))))))) + (inst movq value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)))))) + +(define-vop (raw-instance-ref-c/complex-single) + (:translate %raw-instance-ref/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset))) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst movq value (make-ea-for-raw-slot object tmp :index index)))) (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)) + (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))) @@ -675,35 +821,43 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (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))) - (inst movss (make-ea :dword - :base object - :index tmp - :disp (- (* (1- instance-slots-offset) n-word-bytes) - instance-pointer-lowtag)) - value-real) - (unless (location= value-real result-real) - (inst movss result-real value-real))) - (let ((value-imag (complex-single-reg-imag-tn value)) - (result-imag (complex-single-reg-imag-tn result))) - (inst movss (make-ea :dword - :base object - :index tmp - :disp (+ (* (1- instance-slots-offset) n-word-bytes) - 4 - (- instance-pointer-lowtag))) - value-imag) - (unless (location= value-imag result-imag) - (inst movss result-imag value-imag))))) + (move result value) + (inst movq (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value))) + +(define-vop (raw-instance-set-c/complex-single) + (:translate %raw-instance-set/complex-single) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (complex-single-reg) :target result)) + (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset)) + complex-single-float) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (move result value) + (inst movq (make-ea-for-raw-slot object tmp :index index) value))) + +(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 4 + (inst movq (make-ea-for-raw-slot object instance-length :index index) value))) (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))) + (index :scs (any-reg))) (:arg-types * positive-fixnum) (:temporary (:sc unsigned-reg) tmp) (:results (value :scs (complex-double-reg))) @@ -711,31 +865,32 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (inst shl tmp n-fixnum-tag-bits) (inst sub tmp index) - (let ((real-tn (complex-double-reg-real-tn value))) - (inst movsd - real-tn - (make-ea :dword - :base object - :index tmp - :disp (- (* (- instance-slots-offset 2) n-word-bytes) - instance-pointer-lowtag)))) - (let ((imag-tn (complex-double-reg-imag-tn value))) - (inst movsd - imag-tn - (make-ea :dword - :base object - :index tmp - :disp (- (* (1- instance-slots-offset) n-word-bytes) - instance-pointer-lowtag)))))) + (inst movdqu value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)) :adjustment -8)))) + +(define-vop (raw-instance-ref-c/complex-double) + (:translate %raw-instance-ref/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset))) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (value :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (inst movdqu value (make-ea-for-raw-slot object tmp :index index :adjustment -8)))) (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)) + (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))) @@ -743,25 +898,34 @@ (:generator 5 (loadw tmp object 0 instance-pointer-lowtag) (inst shr tmp n-widetag-bits) - (inst shl tmp 3) + (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))) - (inst movsd (make-ea :dword - :base object - :index tmp - :disp (- (* (- instance-slots-offset 2) n-word-bytes) - instance-pointer-lowtag)) - value-real) - (unless (location= value-real result-real) - (inst movsd result-real value-real))) - (let ((value-imag (complex-double-reg-imag-tn value)) - (result-imag (complex-double-reg-imag-tn result))) - (inst movsd (make-ea :dword - :base object - :index tmp - :disp (- (* (1- instance-slots-offset) n-word-bytes) - instance-pointer-lowtag)) - value-imag) - (unless (location= value-imag result-imag) - (inst movsd result-imag value-imag))))) + (move result value) + (inst movdqu (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)) :adjustment -8) value))) + +(define-vop (raw-instance-set-c/complex-double) + (:translate %raw-instance-set/complex-double) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (complex-double-reg) :target result)) + (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes + #.instance-pointer-lowtag + #.instance-slots-offset)) + complex-double-float) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:generator 4 + (loadw tmp object 0 instance-pointer-lowtag) + (inst shr tmp n-widetag-bits) + (move result value) + (inst movdqu (make-ea-for-raw-slot object tmp :index index :adjustment -8) value))) + +(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 4 + (inst movdqu (make-ea-for-raw-slot object instance-length :index index :adjustment -8) value)))