X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Fcell.lisp;h=7a2eb8d91542aba220a049b09ed98c29ca40add1;hb=f5c5f4ebb0486cddc6cdba2a0687b1d6c52baf2f;hp=ddb3c2fd88c1c9a8183dd73c8825003bb614efd4;hpb=9856bad55a19c2d7787243958431d9a73d40f909;p=sbcl.git diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp index ddb3c2f..7a2eb8d 100644 --- a/src/compiler/ppc/cell.lisp +++ b/src/compiler/ppc/cell.lisp @@ -24,7 +24,7 @@ (define-vop (set-slot) (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) + (value :scs (descriptor-reg any-reg))) (:info name offset lowtag) (:ignore name) (:results) @@ -35,7 +35,7 @@ ;;;; Symbol hacking VOPs: ;;; 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 +49,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 +133,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) @@ -91,7 +166,7 @@ ;; 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 clrrwi res res (1- n-lowtag-bits)))) + (inst clrrwi res res n-fixnum-tag-bits))) ;;;; Fdefinition (fdefn) objects. @@ -108,14 +183,14 @@ (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) (:policy :fast-safe) (:translate (setf fdefn-fun)) (:args (function :scs (descriptor-reg) :target result) - (fdefn :scs (descriptor-reg))) + (fdefn :scs (descriptor-reg))) (:temporary (:scs (interior-reg)) lip) (:temporary (:scs (non-descriptor-reg)) type) (:results (result :scs (descriptor-reg))) @@ -125,9 +200,9 @@ (inst cmpwi type simple-fun-header-widetag) ;;(inst mr lip function) (inst addi lip function - (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)) + (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)) (inst beq normal-fn) - (inst lr lip (make-fixup (extern-alien-name "closure_tramp") :foreign)) + (inst lr lip (make-fixup "closure_tramp" :foreign)) (emit-label normal-fn) (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag) (storew function fdefn fdefn-fun-slot other-pointer-lowtag) @@ -141,7 +216,7 @@ (:results (result :scs (descriptor-reg))) (:generator 38 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag) - (inst lr temp (make-fixup (extern-alien-name "undefined_tramp") :foreign)) + (inst lr temp (make-fixup "undefined_tramp" :foreign)) (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag) (move result fdefn))) @@ -155,7 +230,7 @@ (define-vop (bind) (:args (val :scs (any-reg descriptor-reg)) - (symbol :scs (descriptor-reg))) + (symbol :scs (descriptor-reg))) (:temporary (:scs (descriptor-reg)) temp) (:generator 5 (loadw temp symbol symbol-value-slot other-pointer-lowtag) @@ -172,6 +247,7 @@ (loadw value bsp-tn (- binding-value-slot binding-size)) (storew value symbol symbol-value-slot other-pointer-lowtag) (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)))) @@ -181,8 +257,8 @@ (:temporary (:scs (descriptor-reg)) symbol value) (:generator 0 (let ((loop (gen-label)) - (skip (gen-label)) - (done (gen-label))) + (skip (gen-label)) + (done (gen-label))) (move where arg) (inst cmpw where bsp-tn) (inst beq done) @@ -196,6 +272,7 @@ (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) @@ -218,10 +295,6 @@ (:variant funcallable-instance-info-offset fun-pointer-lowtag) (:translate %set-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)) @@ -252,27 +325,14 @@ (loadw temp struct 0 instance-pointer-lowtag) (inst srwi res temp n-widetag-bits))) -(define-vop (instance-ref slot-ref) - (:variant instance-slots-offset instance-pointer-lowtag) - (:policy :fast-safe) - (:translate %instance-ref) - (:arg-types * (:constant index))) - -#+nil -(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-vop (instance-index-ref word-index-ref) - (:policy :fast-safe) + (:policy :fast-safe) (:translate %instance-ref) (:variant instance-slots-offset instance-pointer-lowtag) (:arg-types instance positive-fixnum)) (define-vop (instance-index-set word-index-set) - (:policy :fast-safe) + (:policy :fast-safe) (:translate %instance-set) (:variant instance-slots-offset instance-pointer-lowtag) (:arg-types instance positive-fixnum *)) @@ -292,3 +352,301 @@ (:policy :fast-safe) (:variant 0 other-pointer-lowtag)) + + +;;;; 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-ref/word) + (:translate %raw-instance-ref/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (unsigned-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types unsigned-num) + (:generator 5 + (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)) + (inst lwzx value object offset))) + +(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))) + (:arg-types * positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types unsigned-num) + (:generator 5 + (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)) + (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) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types single-float) + (:generator 5 + (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)) + (inst lfsx value object offset))) + +(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)) + (:arg-types * positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:result-types single-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (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)) + (inst stfsx value object offset) + (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) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types double-float) + (:generator 5 + (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 + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (inst lfdx value object offset))) + +(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)) + (:arg-types * positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:result-types double-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (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 + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (inst stfdx value object offset) + (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) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types complex-single-float) + (:generator 5 + (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 + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (inst lfsx (complex-single-reg-real-tn value) object offset) + (inst addi offset offset n-word-bytes) + (inst lfsx (complex-single-reg-imag-tn value) object offset))) + +(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)) + (:arg-types * positive-fixnum complex-single-float) + (:results (result :scs (complex-single-reg))) + (:result-types complex-single-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (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 + (- (* (- instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag)) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst stfsx value-real object offset) + (unless (location= result-real value-real) + (inst frsp result-real value-real))) + (inst addi offset offset n-word-bytes) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst stfsx value-imag object offset) + (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) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * positive-fixnum) + (:results (value :scs (complex-double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:result-types complex-double-float) + (:generator 5 + (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 + (- (* (- instance-slots-offset 4) n-word-bytes) + instance-pointer-lowtag)) + (inst lfdx (complex-double-reg-real-tn value) object offset) + (inst addi offset offset (* 2 n-word-bytes)) + (inst lfdx (complex-double-reg-imag-tn value) object offset))) + +(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)) + (:arg-types * positive-fixnum complex-double-float) + (:results (result :scs (complex-double-reg))) + (:result-types complex-double-float) + (:temporary (:scs (non-descriptor-reg)) offset) + (:generator 5 + (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 + (- (* (- instance-slots-offset 4) n-word-bytes) + instance-pointer-lowtag)) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (inst stfdx value-real object offset) + (unless (location= result-real value-real) + (inst fmr result-real value-real))) + (inst addi offset offset (* 2 n-word-bytes)) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst stfdx value-imag object offset) + (unless (location= result-imag value-imag) + (inst fmr result-imag value-imag)))))