X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmips%2Fcell.lisp;h=79b2bbead8b5dff0ba0d448a6fec5a42d957181e;hb=b09c2e67a5d192f72f2c2271c01fc9cbc6eb40d8;hp=1151b6c55c3dbef8188a42c82344f69cc799e783;hpb=4ae1b794a5d6a90794468cf8017f5307f2c30dfe;p=sbcl.git diff --git a/src/compiler/mips/cell.lisp b/src/compiler/mips/cell.lisp index 1151b6c..79b2bbe 100644 --- a/src/compiler/mips/cell.lisp +++ b/src/compiler/mips/cell.lisp @@ -1,5 +1,16 @@ -(in-package "SB!VM") +;;;; the VM definition of various primitive memory access VOPs for +;;;; MIPS + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. +(in-package "SB!VM") ;;;; Data object ref/set stuff. @@ -13,7 +24,7 @@ (define-vop (set-slot) (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg null zero))) + (value :scs (descriptor-reg any-reg null zero))) (:info name offset lowtag) (:ignore name) (:results) @@ -67,8 +78,8 @@ (loadw value object symbol-value-slot other-pointer-lowtag) (inst xor temp value unbound-marker-widetag) (if not-p - (inst beq temp zero-tn target) - (inst bne temp zero-tn target)) + (inst beq temp zero-tn target) + (inst bne temp zero-tn target)) (inst nop))) (define-vop (fast-symbol-value cell-ref) @@ -76,6 +87,23 @@ (: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) + (:temporary (:scs (any-reg)) temp) + (: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 + ;; + ;; wow, MIPS sucks (or I do) -- CSR, 2004-05-20 + (inst li temp (fixnumize -1)) + (loadw res symbol symbol-hash-slot other-pointer-lowtag) + (inst and res temp))) ;;;; Fdefinition (fdefn) objects. @@ -99,7 +127,7 @@ (: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))) @@ -110,8 +138,8 @@ (inst xor type simple-fun-header-widetag) (inst beq type zero-tn normal-fn) (inst addu lip function - (- (ash simple-fun-code-offset word-shift) - fun-pointer-lowtag)) + (- (ash simple-fun-code-offset word-shift) + fun-pointer-lowtag)) (inst li lip (make-fixup "closure_tramp" :foreign)) (emit-label normal-fn) (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag) @@ -140,7 +168,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) @@ -156,6 +184,7 @@ (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)) (inst addu bsp-tn bsp-tn (* -2 n-word-bytes)))) @@ -166,8 +195,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 beq where bsp-tn done) (inst nop) @@ -177,6 +206,7 @@ (inst beq symbol zero-tn skip) (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)) (emit-label skip) @@ -234,19 +264,6 @@ (loadw res struct 0 instance-pointer-lowtag) (inst srl res n-widetag-bits))) -(define-vop (instance-ref slot-ref) - (:variant instance-slots-offset instance-pointer-lowtag) - (:policy :fast-safe) - (:translate %instance-ref) - (:arg-types instance (: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-full-reffer instance-index-ref * instance-slots-offset instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref) @@ -264,4 +281,347 @@ (descriptor-reg any-reg null zero) * code-header-set) + +;;;; 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) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset n-word-bytes) + (inst addu lip offset object) + (inst lw value lip (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)))) + +(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) :target result)) + (: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) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset n-word-bytes) + (inst addu lip offset object) + (inst sw value lip (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)) + (move result value))) + +(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) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset n-word-bytes) + (inst addu lip offset object) + (inst lwc1 value lip (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)))) + +(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))) + (: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) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset n-word-bytes) + (inst addu lip offset object) + (inst swc1 value lip (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)) + (unless (location= result value) + (inst fmove :single result value)))) + +(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) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 2 n-word-bytes)) + (inst addu lip offset object) + (let ((immediate-offset (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1 value lip immediate-offset)) + (:little-endian (inst lwc1-odd value lip immediate-offset)))) + (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1-odd value lip immediate-offset)) + (:little-endian (inst lwc1 value lip immediate-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))) + (: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) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 2 n-word-bytes)) + (inst addu lip offset object) + (let ((immediate-offset (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1 value lip immediate-offset)) + (:little-endian (inst swc1-odd value lip immediate-offset)))) + (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1-odd value lip immediate-offset)) + (:little-endian (inst swc1 value lip immediate-offset)))) + (unless (location= result value) + (inst fmove :double result value)))) + +(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) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 2 n-word-bytes)) + (inst addu lip offset object) + (inst lwc1 + (complex-single-reg-real-tn value) + lip + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)) + (inst lwc1 + (complex-single-reg-imag-tn value) + lip + (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)))) + +(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))) + (: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) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 2 n-word-bytes)) + (inst addu lip offset object) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst swc1 + value-real + lip + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)) + (unless (location= result-real value-real) + (inst fmove :single result-real value-real))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst swc1 + value-imag + lip + (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag)) + (unless (location= result-imag value-imag) + (inst fmove :single result-imag value-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) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 4 n-word-bytes)) + (inst addu lip offset object) + (let ((immediate-offset (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1 + (complex-double-reg-real-tn value) + lip + immediate-offset)) + (:little-endian (inst lwc1-odd + (complex-double-reg-real-tn value) + lip + immediate-offset)))) + (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1-odd + (complex-double-reg-real-tn value) + lip + immediate-offset)) + (:little-endian (inst lwc1 + (complex-double-reg-real-tn value) + lip + immediate-offset)))) + (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1 + (complex-double-reg-imag-tn value) + lip + immediate-offset)) + (:little-endian (inst lwc1-odd + (complex-double-reg-imag-tn value) + lip + immediate-offset)))) + (let ((immediate-offset (- (* (+ instance-slots-offset 3) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst lwc1-odd + (complex-double-reg-imag-tn value) + lip + immediate-offset)) + (:little-endian (inst lwc1 + (complex-double-reg-imag-tn value) + lip + immediate-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))) + (: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) + (inst sll offset 2) + (inst subu offset index) + (inst subu offset (* 4 n-word-bytes)) + (inst addu lip offset object) + (let ((value-real (complex-double-reg-real-tn value)) + (result-real (complex-double-reg-real-tn result))) + (let ((immediate-offset (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1 + value-real + lip + immediate-offset)) + (:little-endian (inst swc1-odd + value-real + lip + immediate-offset)))) + (let ((immediate-offset (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1-odd + value-real + lip + immediate-offset)) + (:little-endian (inst swc1 + value-real + lip + immediate-offset)))) + (unless (location= result-real value-real) + (inst fmove :double result-real value-real))) + (let ((value-imag (complex-double-reg-imag-tn value)) + (result-imag (complex-double-reg-imag-tn result))) + (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1 + value-imag + lip + immediate-offset)) + (:little-endian (inst swc1-odd + value-imag + lip + immediate-offset)))) + (let ((immediate-offset (- (* (+ instance-slots-offset 3) n-word-bytes) + instance-pointer-lowtag))) + (ecase *backend-byte-order* + (:big-endian (inst swc1-odd + value-imag + lip + immediate-offset)) + (:little-endian (inst swc1 + value-imag + lip + immediate-offset)))) + (unless (location= result-imag value-imag) + (inst fmove :double result-imag value-imag)))))