X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Fcell.lisp;h=fda746e4edcb4406ff0d9625573a55196423d7d7;hb=988c0c0982e8ebb891da9241c71b5f8350448350;hp=553dfe82878e5b14bf8adca8d60db16b3b70f37e;hpb=b9e94e326f79ab01e56cb437e424ce5ea489471f;p=sbcl.git diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp index 553dfe8..fda746e 100644 --- a/src/compiler/ppc/cell.lisp +++ b/src/compiler/ppc/cell.lisp @@ -31,11 +31,71 @@ (:generator 1 (storew value object offset lowtag))) +#!+compare-and-swap-vops +(define-vop (compare-and-swap-slot) + (:args (object :scs (descriptor-reg)) + (old :scs (descriptor-reg any-reg)) + (new :scs (descriptor-reg any-reg))) + (:temporary (:sc non-descriptor-reg) temp) + (:info name offset lowtag) + (:ignore name) + (:results (result :scs (descriptor-reg) :from :load)) + (:generator 5 + (inst sync) + (inst li temp (- (* offset n-word-bytes) lowtag)) + LOOP + (inst lwarx result temp object) + (inst cmpw result old) + (inst bne EXIT) + (inst stwcx. new temp object) + (inst bne LOOP) + EXIT + (inst isync))) + ;;;; Symbol hacking VOPs: +#!+compare-and-swap-vops +(define-vop (%compare-and-swap-symbol-value) + (:translate %compare-and-swap-symbol-value) + (:args (symbol :scs (descriptor-reg)) + (old :scs (descriptor-reg any-reg)) + (new :scs (descriptor-reg any-reg))) + (:temporary (:sc non-descriptor-reg) temp) + (:results (result :scs (descriptor-reg any-reg) :from :load)) + (:policy :fast-safe) + (:vop-var vop) + (:generator 15 + (inst sync) + #!+sb-thread + (assemble () + (loadw temp symbol symbol-tls-index-slot other-pointer-lowtag) + ;; Thread-local area, no synchronization needed. + (inst lwzx result thread-base-tn temp) + (inst cmpw result old) + (inst bne DONT-STORE-TLS) + (inst stwx new thread-base-tn temp) + DONT-STORE-TLS + + (inst cmpwi result no-tls-value-marker-widetag) + (inst bne CHECK-UNBOUND)) + + (inst li temp (- (* symbol-value-slot n-word-bytes) + other-pointer-lowtag)) + LOOP + (inst lwarx result symbol temp) + (inst cmpw result old) + (inst bne CHECK-UNBOUND) + (inst stwcx. new symbol temp) + (inst bne LOOP) + + CHECK-UNBOUND + (inst isync) + (inst cmpwi result unbound-marker-widetag) + (inst beq (generate-error-code vop 'unbound-symbol-error symbol)))) + ;;; The compiler likes to be able to directly SET symbols. -(define-vop (set cell-set) +(define-vop (%set-symbol-global-value cell-set) (:variant symbol-value-slot other-pointer-lowtag)) ;;; Do a cell ref with an error check for being unbound. @@ -49,15 +109,81 @@ ;;; With SYMBOL-VALUE, we check that the value isn't the trap object. ;;; So SYMBOL-VALUE of NIL is NIL. -(define-vop (symbol-value checked-cell-ref) - (:translate symbol-value) +(define-vop (symbol-global-value checked-cell-ref) + (:translate symbol-global-value) (:generator 9 (move obj-temp object) (loadw value obj-temp symbol-value-slot other-pointer-lowtag) - (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) + (let ((err-lab (generate-error-code vop 'unbound-symbol-error obj-temp))) (inst cmpwi value unbound-marker-widetag) (inst beq err-lab)))) +(define-vop (fast-symbol-global-value cell-ref) + (:variant symbol-value-slot other-pointer-lowtag) + (:policy :fast) + (:translate symbol-global-value)) + +#!+sb-thread +(progn + (define-vop (set) + (:args (symbol :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:temporary (:sc any-reg) tls-slot temp) + (:generator 4 + (loadw tls-slot symbol symbol-tls-index-slot other-pointer-lowtag) + (inst lwzx temp thread-base-tn tls-slot) + (inst cmpwi temp no-tls-value-marker-widetag) + (inst beq GLOBAL-VALUE) + (inst stwx value thread-base-tn tls-slot) + (inst b DONE) + GLOBAL-VALUE + (storew value symbol symbol-value-slot other-pointer-lowtag) + 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 + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst lwzx value thread-base-tn value) + (inst cmpwi value no-tls-value-marker-widetag) + (inst bne CHECK-UNBOUND) + (loadw value object symbol-value-slot other-pointer-lowtag) + CHECK-UNBOUND + (inst cmpwi value unbound-marker-widetag) + (inst beq (generate-error-code vop 'unbound-symbol-error object)))) + + (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 + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst lwzx value thread-base-tn value) + (inst cmpwi value no-tls-value-marker-widetag) + (inst bne DONE) + (loadw value object symbol-value-slot other-pointer-lowtag) + DONE))) + +;;; On unithreaded builds these are just copies of the global versions. +#!-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))) + ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell ;;; is bound. (define-vop (boundp-frob) @@ -67,17 +193,26 @@ (:policy :fast-safe) (:temporary (:scs (descriptor-reg)) value)) +#!+sb-thread (define-vop (boundp boundp-frob) (:translate boundp) (:generator 9 + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst lwzx value thread-base-tn value) + (inst cmpwi value no-tls-value-marker-widetag) + (inst bne CHECK-UNBOUND) (loadw value object symbol-value-slot other-pointer-lowtag) + CHECK-UNBOUND (inst cmpwi value unbound-marker-widetag) (inst b? (if not-p :eq :ne) target))) -(define-vop (fast-symbol-value cell-ref) - (:variant symbol-value-slot other-pointer-lowtag) - (:policy :fast) - (:translate symbol-value)) +#!-sb-thread +(define-vop (boundp boundp-frob) + (:translate boundp) + (:generator 9 + (loadw value object symbol-value-slot other-pointer-lowtag) + (inst cmpwi value unbound-marker-widetag) + (inst b? (if not-p :eq :ne) target))) (define-vop (symbol-hash) (:policy :fast-safe) @@ -108,7 +243,7 @@ (move obj-temp object) (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag) (inst cmpw value null-tn) - (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp))) + (let ((err-lab (generate-error-code vop 'undefined-fun-error obj-temp))) (inst beq err-lab)))) (define-vop (set-fdefn-fun) @@ -153,6 +288,63 @@ ;;; the symbol on the binding stack and stuff the new value into the ;;; symbol. +#!+sb-thread +(define-vop (bind) + (:args (val :scs (any-reg descriptor-reg)) + (symbol :scs (descriptor-reg))) + (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) + (:temporary (:scs (descriptor-reg)) temp tls-index) + (:generator 5 + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (inst cmpwi tls-index 0) + (inst bne TLS-VALID) + + ;; No TLS slot allocated, so allocate one. + (pseudo-atomic (pa-flag) + (without-scheduling () + (assemble () + (inst li temp (+ (static-symbol-offset '*tls-index-lock*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) + OBTAIN-LOCK + (inst lwarx tls-index null-tn temp) + (inst cmpwi tls-index 0) + (inst bne OBTAIN-LOCK) + (inst stwcx. thread-base-tn null-tn temp) + (inst bne OBTAIN-LOCK) + (inst isync) + + ;; Check to see if the TLS index was set while we were waiting. + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (inst cmpwi tls-index 0) + (inst bne RELEASE-LOCK) + + (load-symbol-value tls-index *free-tls-index*) + ;; FIXME: Check for TLS index overflow. + (inst addi tls-index tls-index n-word-bytes) + (store-symbol-value tls-index *free-tls-index*) + (inst addi tls-index tls-index (- n-word-bytes)) + (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + + ;; The sync instruction doesn't need to happen if we branch + ;; directly to RELEASE-LOCK as we didn't do any stores in that + ;; case. + (inst sync) + RELEASE-LOCK + (inst stwx zero-tn null-tn temp) + + ;; temp is a boxed register, but we've been storing crap in it. + ;; fix it before we leave pseudo-atomic. + (inst li temp 0)))) + + TLS-VALID + (inst lwzx temp thread-base-tn tls-index) + (inst addi bsp-tn bsp-tn (* 2 n-word-bytes)) + (storew temp bsp-tn (- binding-value-slot binding-size)) + (storew symbol bsp-tn (- binding-symbol-slot binding-size)) + (inst stwx val thread-base-tn tls-index))) + +#!-sb-thread (define-vop (bind) (:args (val :scs (any-reg descriptor-reg)) (symbol :scs (descriptor-reg))) @@ -164,15 +356,27 @@ (storew symbol bsp-tn (- binding-symbol-slot binding-size)) (storew val symbol symbol-value-slot other-pointer-lowtag))) +#!+sb-thread +(define-vop (unbind) + (:temporary (:scs (descriptor-reg)) tls-index value) + (:generator 0 + (loadw tls-index bsp-tn (- binding-symbol-slot binding-size)) + (loadw tls-index tls-index symbol-tls-index-slot other-pointer-lowtag) + (loadw value bsp-tn (- binding-value-slot binding-size)) + (inst stwx value thread-base-tn tls-index) + (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) + (storew zero-tn bsp-tn (- binding-value-slot binding-size)) + (inst subi bsp-tn bsp-tn (* 2 n-word-bytes)))) +#!-sb-thread (define-vop (unbind) (:temporary (:scs (descriptor-reg)) symbol value) (:generator 0 (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) (loadw value bsp-tn (- binding-value-slot binding-size)) (storew value symbol symbol-value-slot other-pointer-lowtag) - (storew zero-tn bsp-tn (- binding-value-slot binding-size)) (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) + (storew zero-tn bsp-tn (- binding-value-slot binding-size)) (inst subi bsp-tn bsp-tn (* 2 n-word-bytes)))) @@ -193,11 +397,16 @@ (inst cmpwi symbol 0) (inst beq skip) (loadw value bsp-tn (- binding-value-slot binding-size)) + #!+sb-thread + (loadw symbol symbol symbol-tls-index-slot other-pointer-lowtag) + #!+sb-thread + (inst stwx value thread-base-tn symbol) + #!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag) - (storew zero-tn bsp-tn (- binding-value-slot binding-size)) (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) (emit-label skip) + (storew zero-tn bsp-tn (- binding-value-slot binding-size)) (inst subi bsp-tn bsp-tn (* 2 n-word-bytes)) (inst cmpw where bsp-tn) (inst bne loop) @@ -262,7 +471,12 @@ (:variant instance-slots-offset instance-pointer-lowtag) (:arg-types instance positive-fixnum *)) - +#!+compare-and-swap-vops +(define-vop (%compare-and-swap-instance-ref word-index-cas) + (:policy :fast-safe) + (:translate %compare-and-swap-instance-ref) + (:variant instance-slots-offset instance-pointer-lowtag) + (:arg-types instance tagged-num * *)) ;;;; Code object frobbing. @@ -281,6 +495,51 @@ ;;;; raw instance slot accessors +(defun offset-for-raw-slot (instance-length index n-words) + (+ (* (- instance-length instance-slots-offset index (1- n-words)) + n-word-bytes) + (- instance-pointer-lowtag))) + +(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 stw value object (offset-for-raw-slot instance-length index 1)))) + +(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)) + (diff :scs (unsigned-reg))) + (:arg-types * positive-fixnum unsigned-num) + (:temporary (:sc unsigned-reg) offset) + (:temporary (:sc non-descriptor-reg) sum) + (:results (result :scs (unsigned-reg) :from :load)) + (:result-types unsigned-num) + (:generator 4 + (loadw offset object 0 instance-pointer-lowtag) + ;; offset = (offset >> n-widetag-bits) << 2 + (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29) + (inst subf offset index offset) + (inst addi + offset + offset + (- (* (1- instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + ;; load the slot value, add DIFF, write the sum back, and return + ;; the original slot value, atomically, and include a memory + ;; barrier. + (inst sync) + LOOP + (inst lwarx result offset object) + (inst add sum result diff) + (inst stwcx. sum offset object) + (inst bne LOOP) + (inst isync))) + (define-vop (raw-instance-ref/word) (:translate %raw-instance-ref/word) (:policy :fast-safe) @@ -325,6 +584,14 @@ (inst stwx value object offset) (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 stfs value object (offset-for-raw-slot instance-length index 1)))) + (define-vop (raw-instance-ref/single) (:translate %raw-instance-ref/single) (:policy :fast-safe) @@ -370,6 +637,14 @@ (unless (location= result value) (inst frsp 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 stfd value object (offset-for-raw-slot instance-length index 2)))) + (define-vop (raw-instance-ref/double) (:translate %raw-instance-ref/double) (:policy :fast-safe) @@ -415,6 +690,17 @@ (unless (location= result value) (inst fmr result 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 stfs (complex-single-reg-real-tn value) + object (offset-for-raw-slot instance-length index 2)) + (inst stfs (complex-single-reg-imag-tn value) + object (offset-for-raw-slot instance-length index 1)))) + (define-vop (raw-instance-ref/complex-single) (:translate %raw-instance-ref/complex-single) (:policy :fast-safe) @@ -470,6 +756,17 @@ (unless (location= result-imag value-imag) (inst frsp result-imag 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 4 + (inst stfd (complex-single-reg-real-tn value) + object (offset-for-raw-slot instance-length index 4)) + (inst stfd (complex-double-reg-imag-tn value) + object (offset-for-raw-slot instance-length index 2)))) + (define-vop (raw-instance-ref/complex-double) (:translate %raw-instance-ref/complex-double) (:policy :fast-safe)