X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Farray.lisp;h=37cf6ea16841d7d352af936b3253c7301b6e3781;hb=5745b5a5b2e3b967bf3876b4306f31b3c78495fa;hp=16b4f0614c29270ea1d6a10b792a2d69d882fd9d;hpb=52cfe54802db8736f1f4e2b67764c43bba9b78b3;p=sbcl.git diff --git a/src/compiler/ppc/array.lisp b/src/compiler/ppc/array.lisp index 16b4f06..37cf6ea 100644 --- a/src/compiler/ppc/array.lisp +++ b/src/compiler/ppc/array.lisp @@ -23,17 +23,21 @@ (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:temporary (:scs (non-descriptor-reg)) ndescr) + (:temporary (:scs (non-descriptor-reg)) gc-temp) + #!-gencgc (:ignore gc-temp) (:results (result :scs (descriptor-reg))) (:generator 0 (pseudo-atomic (pa-flag) - (inst ori header alloc-tn other-pointer-lowtag) - (inst addi ndescr rank (* (1+ array-dimensions-offset) n-word-bytes)) + (inst addi ndescr rank (+ (* (1+ array-dimensions-offset) n-word-bytes) + lowtag-mask)) (inst clrrwi ndescr ndescr n-lowtag-bits) - (inst add alloc-tn alloc-tn ndescr) + (allocation header ndescr other-pointer-lowtag + :temp-tn gc-temp + :flag-tn pa-flag) (inst addi ndescr rank (fixnumize (1- array-dimensions-offset))) (inst slwi ndescr ndescr n-widetag-bits) (inst or ndescr ndescr type) - (inst srwi ndescr ndescr 2) + (inst srwi ndescr ndescr n-fixnum-tag-bits) (storew ndescr header 0 other-pointer-lowtag)) (move result header))) @@ -59,7 +63,7 @@ (loadw temp x 0 other-pointer-lowtag) (inst srawi temp temp n-widetag-bits) (inst subi temp temp (1- array-dimensions-offset)) - (inst slwi res temp 2))) + (inst slwi res temp n-fixnum-tag-bits))) ;;;; Bounds checking routine. @@ -74,7 +78,7 @@ (:vop-var vop) (:save-p :compute-only) (:generator 5 - (let ((error (generate-error-code vop invalid-array-index-error + (let ((error (generate-error-code vop 'invalid-array-index-error array bound index))) (inst cmplw index bound) (inst bge error) @@ -136,6 +140,13 @@ (def-data-vector-frobs simple-array-signed-byte-32 word-index signed-num signed-reg)) +#!+compare-and-swap-vops +(define-vop (%compare-and-swap-svref word-index-cas) + (:note "inline array compare-and-swap") + (:policy :fast-safe) + (:variant vector-data-offset other-pointer-lowtag) + (:translate %compare-and-swap-svref) + (:arg-types simple-vector positive-fixnum * *)) ;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit, ;;; and 4-bit vectors. @@ -156,8 +167,8 @@ (:result-types positive-fixnum) (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result) (:generator 20 - (inst srwi temp index ,bit-shift) - (inst slwi temp temp 2) + ;; temp = (index >> bit-shift) << 2) + (inst rlwinm temp index ,(- 32 (- bit-shift 2)) ,(- bit-shift 2) 29) (inst addi temp temp (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) (inst lwzx result object temp) @@ -167,7 +178,7 @@ `((inst slwi temp temp ,(1- (integer-length bits))))) (inst srw result result temp) (inst andi. result result ,(1- (ash 1 bits))) - (inst slwi value result 2))) + (inst slwi value result n-fixnum-tag-bits))) (define-vop (,(symbolicate 'data-vector-ref-c/ type)) (:translate data-vector-ref) (:policy :fast-safe) @@ -206,8 +217,8 @@ (:temporary (:scs (non-descriptor-reg)) temp old offset) (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift) (:generator 25 - (inst srwi offset index ,bit-shift) - (inst slwi offset offset 2) + ;; offset = (index >> bit-shift) << 2) + (inst rlwinm offset index ,(- 32 (- bit-shift 2)) ,(- bit-shift 2) 29) (inst addi offset offset (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) (inst lwzx old object offset) @@ -219,8 +230,7 @@ (= (tn-value value) ,(1- (ash 1 bits)))) (inst lr temp ,(1- (ash 1 bits))) (inst slw temp temp shift) - (inst not temp temp) - (inst and old old temp)) + (inst andc old old temp)) (unless (sc-is value zero) (sc-case value (immediate @@ -259,8 +269,7 @@ (unless (and (sc-is value immediate) (= (tn-value value) ,(1- (ash 1 bits)))) (cond ((zerop extra) - (inst slwi old old ,bits) - (inst srwi old old ,bits)) + (inst clrlwi old old ,bits)) (t (inst lr temp (lognot (ash ,(1- (ash 1 bits)) @@ -472,68 +481,10 @@ (inst fmr result-imag value-imag))))) -;;; These VOPs are used for implementing float slots in structures (whose raw -;;; data is an unsigned-32 vector. -;;; -(define-vop (raw-ref-single data-vector-ref/simple-array-single-float) - (:translate %raw-ref-single) - (:arg-types sb!c::raw-vector positive-fixnum)) -;;; -(define-vop (raw-set-single data-vector-set/simple-array-single-float) - (:translate %raw-set-single) - (:arg-types sb!c::raw-vector positive-fixnum single-float)) -;;; -(define-vop (raw-ref-double data-vector-ref/simple-array-double-float) - (:translate %raw-ref-double) - (:arg-types sb!c::raw-vector positive-fixnum)) -;;; -(define-vop (raw-set-double data-vector-set/simple-array-double-float) - (:translate %raw-set-double) - (:arg-types sb!c::raw-vector positive-fixnum double-float)) - -(define-vop (raw-ref-complex-single - data-vector-ref/simple-array-complex-single-float) - (:translate %raw-ref-complex-single) - (:arg-types sb!c::raw-vector positive-fixnum)) -;;; -(define-vop (raw-set-complex-single - data-vector-set/simple-array-complex-single-float) - (:translate %raw-set-complex-single) - (:arg-types sb!c::raw-vector positive-fixnum complex-single-float)) -;;; -(define-vop (raw-ref-complex-double - data-vector-ref/simple-array-complex-double-float) - (:translate %raw-ref-complex-double) - (:arg-types sb!c::raw-vector positive-fixnum)) -;;; -(define-vop (raw-set-complex-double - data-vector-set/simple-array-complex-double-float) - (:translate %raw-set-complex-double) - (:arg-types sb!c::raw-vector positive-fixnum complex-double-float)) - - ;;; These vops are useful for accessing the bits of a vector irrespective of ;;; what type of vector it is. ;;; -(define-vop (raw-bits word-index-ref) - (:note "raw-bits VOP") - (:translate %raw-bits) - (:results (value :scs (unsigned-reg))) - (:result-types unsigned-num) - (:variant 0 other-pointer-lowtag)) - -(define-vop (set-raw-bits word-index-set) - (:note "setf raw-bits VOP") - (:translate %set-raw-bits) - (:args (object :scs (descriptor-reg)) - (index :scs (any-reg zero immediate)) - (value :scs (unsigned-reg))) - (:arg-types * positive-fixnum unsigned-num) - (:results (result :scs (unsigned-reg))) - (:result-types unsigned-num) - (:variant 0 other-pointer-lowtag)) - (define-vop (vector-raw-bits word-index-ref) (:note "vector-raw-bits VOP") (:translate %vector-raw-bits)