X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fppc%2Fcell.lisp;h=fda746e4edcb4406ff0d9625573a55196423d7d7;hb=988c0c0982e8ebb891da9241c71b5f8350448350;hp=8ac94b3f62c2810f9966785f3c2d21161f77fc7b;hpb=d5e1f093b8ca643ce4f39554232e0a1688e85b7c;p=sbcl.git diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp index 8ac94b3..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,8 +109,8 @@ ;;; 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) @@ -58,6 +118,72 @@ (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) @@ -92,13 +227,6 @@ ;; ensure this is explained in the comment in objdef.lisp (loadw res symbol symbol-hash-slot other-pointer-lowtag) (inst clrrwi res res n-fixnum-tag-bits))) - -;;; On unithreaded builds these are just copies of the non-global versions. -(define-vop (%set-symbol-global-value set)) -(define-vop (symbol-global-value symbol-value) - (:translate symbol-global-value)) -(define-vop (fast-symbol-global-value fast-symbol-value) - (:translate symbol-global-value)) ;;;; Fdefinition (fdefn) objects. @@ -160,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))) @@ -171,7 +356,19 @@ (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 @@ -200,6 +397,11 @@ (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-symbol-slot binding-size)) @@ -269,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. @@ -301,6 +508,38 @@ (: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)