X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Fcell.lisp;h=4e80a7b9749673f6e18bf1673ea497ab3c3d5e64;hb=5cf3c4259d529e180d75d4d140f344e600d2b06b;hp=10734f8cd14686dbf7a2e3434d069d4cadf8e9f6;hpb=6fb6e66f531dfb6140ec3e0cc8f84f6ecd1927ca;p=sbcl.git diff --git a/src/compiler/alpha/cell.lisp b/src/compiler/alpha/cell.lisp index 10734f8..4e80a7b 100644 --- a/src/compiler/alpha/cell.lisp +++ b/src/compiler/alpha/cell.lisp @@ -24,16 +24,16 @@ (define-vop (set-slot) (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg null zero))) - (:info name offset lowtag #+gengc remember) + (value :scs (descriptor-reg any-reg null zero))) + (:info name offset lowtag #!+gengc remember) (:ignore name) (:results) (:generator 1 - #+gengc + #!+gengc (if remember - (storew-and-remember-slot value object offset lowtag) - (storew value object offset lowtag)) - #-gengc + (storew-and-remember-slot value object offset lowtag) + (storew value object offset lowtag)) + #!-gengc (storew value object offset lowtag))) ;;;; symbol hacking VOPs @@ -60,11 +60,11 @@ (move object obj-temp) (loadw value obj-temp symbol-value-slot other-pointer-lowtag) (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp))) - (inst xor value unbound-marker-type temp) + (inst xor value unbound-marker-widetag temp) (inst beq temp err-lab)))) -;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell -;;; is bound. +;;; like CHECKED-CELL-REF, only we are a predicate to see if the cell +;;; is bound (define-vop (boundp-frob) (:args (object :scs (descriptor-reg))) (:conditional) @@ -77,17 +77,29 @@ (:translate boundp) (:generator 9 (loadw value object symbol-value-slot other-pointer-lowtag) - (inst xor value unbound-marker-type temp) + (inst xor value unbound-marker-widetag temp) (if not-p - (inst beq temp target) - (inst bne temp target)))) + (inst beq temp target) + (inst bne temp target)))) (define-vop (fast-symbol-value cell-ref) (:variant symbol-value-slot other-pointer-lowtag) (:policy :fast) (:translate symbol-value)) - +(define-vop (symbol-hash) + (:policy :fast-safe) + (:translate symbol-hash) + (:args (symbol :scs (descriptor-reg))) + (:results (res :scs (any-reg))) + (:result-types positive-fixnum) + (:generator 2 + ;; The symbol-hash slot of NIL holds NIL because it is also the + ;; cdr slot, so we have to strip off the two low bits to make sure + ;; 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 bic res #.(ash lowtag-mask -1) res))) ;;;; fdefinition (FDEFN) objects @@ -104,7 +116,7 @@ (:generator 10 (move object obj-temp) (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag) - (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp))) + (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp))) (inst cmpeq value null-tn temp) (inst bne temp err-lab)))) @@ -112,24 +124,24 @@ (: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))) (:generator 38 (let ((normal-fn (gen-label))) (load-type type function (- fun-pointer-lowtag)) - (inst xor type simple-fun-header-type type) + (inst xor type simple-fun-header-widetag type) (inst addq function - (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag) - lip) + (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag) + lip) (inst beq type normal-fn) (inst li (make-fixup "closure_tramp" :foreign) lip) (emit-label normal-fn) (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag) (storew function fdefn fdefn-fun-slot other-pointer-lowtag) (move function result)))) - + (define-vop (fdefn-makunbound) (:policy :fast-safe) @@ -149,15 +161,15 @@ ;;; symbol on the binding stack and stuff the new value into the symbol. (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) - (inst addq bsp-tn (* 2 word-bytes) bsp-tn) + (inst addq bsp-tn (* 2 n-word-bytes) bsp-tn) (storew temp bsp-tn (- binding-value-slot binding-size)) (storew symbol bsp-tn (- binding-symbol-slot binding-size)) - (#+gengc storew-and-remember-slot #-gengc storew - val symbol symbol-value-slot other-pointer-lowtag))) + (#!+gengc storew-and-remember-slot #!-gengc storew + val symbol symbol-value-slot other-pointer-lowtag))) (define-vop (unbind) @@ -165,10 +177,11 @@ (:generator 0 (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) (loadw value bsp-tn (- binding-value-slot binding-size)) - (#+gengc storew-and-remember-slot #-gengc storew - value symbol symbol-value-slot other-pointer-lowtag) + (#!+gengc storew-and-remember-slot #!-gengc storew + value symbol symbol-value-slot other-pointer-lowtag) (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) - (inst subq bsp-tn (* 2 word-bytes) bsp-tn))) + (storew zero-tn bsp-tn (- binding-value-slot binding-size)) + (inst subq bsp-tn (* 2 n-word-bytes) bsp-tn))) (define-vop (unbind-to-here) @@ -178,8 +191,8 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:generator 0 (let ((loop (gen-label)) - (skip (gen-label)) - (done (gen-label))) + (skip (gen-label)) + (done (gen-label))) (move arg where) (inst cmpeq where bsp-tn temp) (inst bne temp done) @@ -188,12 +201,13 @@ (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) (loadw value bsp-tn (- binding-value-slot binding-size)) (inst beq symbol skip) - (#+gengc storew-and-remember-slot #-gengc storew - value symbol symbol-value-slot other-pointer-lowtag) + (#!+gengc storew-and-remember-slot #!-gengc storew + value symbol symbol-value-slot other-pointer-lowtag) (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) (emit-label skip) - (inst subq bsp-tn (* 2 word-bytes) bsp-tn) + (storew zero-tn bsp-tn (- binding-value-slot binding-size)) + (inst subq bsp-tn (* 2 n-word-bytes) bsp-tn) (inst cmpeq where bsp-tn temp) (inst beq temp loop) @@ -213,9 +227,6 @@ 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)) @@ -240,19 +251,7 @@ (:result-types positive-fixnum) (:generator 4 (loadw res struct 0 instance-pointer-lowtag) - (inst srl res type-bits res))) - -(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) *)) + (inst srl res n-widetag-bits res))) (define-full-reffer instance-index-ref * instance-slots-offset instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref) @@ -270,7 +269,7 @@ ;;;; mutator accessing -#+gengc +#!+gengc (progn (eval-when (:compile-toplevel :load-toplevel :execute) @@ -330,22 +329,22 @@ (offset (symbolicate "MUTATOR-" slot "-SLOT")) (fn (let ((*package* (find-package :kernel))) - (symbolicate "MUTATOR-" slot)))) + (symbolicate "MUTATOR-" slot)))) (multiple-value-bind (lisp-type ref-vop set-vop) (ecase type (:des (values t - 'mutator-descriptor-ref - 'mutator-descriptor-set)) + 'mutator-descriptor-ref + 'mutator-descriptor-set)) (:ub32 (values '(unsigned-byte 32) - 'mutator-ub32-ref - 'mutator-ub32-set)) + 'mutator-ub32-ref + 'mutator-ub32-set)) (:sap (values 'system-area-pointer - 'mutator-sap-ref - 'mutator-sap-set))) + 'mutator-sap-ref + 'mutator-sap-set))) `(progn (export ',fn :kernel) (defknown ,fn () ,lisp-type (flushable)) @@ -354,7 +353,7 @@ (:variant ,offset)) ,@(when writable `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type - (unsafe)) + (unsafe)) (define-vop (,set ,set-vop) (:translate (setf ,fn)) (:variant ,offset))))))))) @@ -369,8 +368,6 @@ (define-mutator-accessors binding-stack-end :sap nil) (define-mutator-accessors number-stack-base :sap nil) (define-mutator-accessors number-stack-end :sap nil) - (define-mutator-accessors eval-stack :des t) - (define-mutator-accessors eval-stack-top :ub32 t) (define-mutator-accessors nursery-start :sap nil) (define-mutator-accessors nursery-end :sap nil) (define-mutator-accessors storebuf-start :sap nil) @@ -378,3 +375,284 @@ (define-mutator-accessors words-consed :ub32 nil)) ); #+gengc progn + + + +;;;; raw instance slot accessors + +(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) + (:temporary (:scs (interior-reg)) lip) + (:result-types unsigned-num) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset n-word-bytes offset) + (inst addq object offset lip) + (inst ldl + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (inst mskll value 4 value))) + +(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) + (:temporary (:scs (interior-reg)) lip) + (:result-types unsigned-num) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset n-word-bytes offset) + (inst addq object offset lip) + (inst stl + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (move value result))) + +(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) + (:temporary (:scs (interior-reg)) lip) + (:result-types single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset n-word-bytes offset) + (inst addq object offset lip) + (inst lds + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip))) + +(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))) + (:arg-types * positive-fixnum single-float) + (:results (result :scs (single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset n-word-bytes offset) + (inst addq object offset lip) + (inst sts + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result value) + (inst fmove value result)))) + +(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) + (:temporary (:scs (interior-reg)) lip) + (:result-types double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 2 n-word-bytes) offset) + (inst addq object offset lip) + (inst ldt + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip))) + +(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))) + (:arg-types * positive-fixnum double-float) + (:results (result :scs (double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 2 n-word-bytes) offset) + (inst addq object offset lip) + (inst stt + value + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result value) + (inst fmove value result)))) + +(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) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 2 n-word-bytes) offset) + (inst addq object offset lip) + (inst lds + (complex-double-reg-real-tn value) + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (inst lds + (complex-double-reg-imag-tn value) + (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag) + lip))) + +(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))) + (:arg-types * positive-fixnum complex-single-float) + (:results (result :scs (complex-single-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-single-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 2 n-word-bytes) offset) + (inst addq object offset lip) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst sts + value-real + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result-real value-real) + (inst fmove value-real result-real))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst sts + value-imag + (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result-imag value-imag) + (inst fmove value-imag result-imag))))) + +(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) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 4 n-word-bytes) offset) + (inst addq object offset lip) + (inst ldt + (complex-double-reg-real-tn value) + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (inst ldt + (complex-double-reg-imag-tn value) + (- (* (+ instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag) + lip))) + +(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))) + (:arg-types * positive-fixnum complex-double-float) + (:results (result :scs (complex-double-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types complex-double-float) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst subq offset index offset) + (inst subq offset (* 4 n-word-bytes) offset) + (inst addq object offset lip) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (inst stt + value-real + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result-real value-real) + (inst fmove value-real result-real))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (inst stt + value-imag + (- (* (+ instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag) + lip) + (unless (location= result-imag value-imag) + (inst fmove value-imag result-imag)))))