X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fhppa%2Fcell.lisp;h=7334e4e9f99c81a663be3b191404b5f5dbd26676;hb=edcaad65452eee6bff2017941ef6c33b26a5a2b0;hp=42879add4bb84e2db1bd67d197ddc072e3561110;hpb=26bbfd93d01cefc0bbf97727379bdbdace8bf609;p=sbcl.git diff --git a/src/compiler/hppa/cell.lisp b/src/compiler/hppa/cell.lisp index 42879ad..7334e4e 100644 --- a/src/compiler/hppa/cell.lisp +++ b/src/compiler/hppa/cell.lisp @@ -251,3 +251,150 @@ (define-full-setter code-header-set * 0 other-pointer-lowtag (descriptor-reg any-reg) * code-header-set) + +;;;; raw instance slot accessors + +(macrolet ((fix-storage (inc-offset-by) + `(progn + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst sub offset index offset) + (inst addi ,inc-offset-by offset offset) + (inst add offset object lip))) + (raw-instance ((type inc-offset-by set &optional complex) + &body body) + (let ((name (symbolicate "RAW-INSTANCE-" + (if set "SET/" "REF/") + (if (eq type 'unsigned) + "WORD" + (or complex type)))) + (type-num (cond + ((eq type 'single) + (if complex 'complex-single-float + 'single-float)) + ((eq type 'double) + (if complex 'complex-double-float + 'double-float)) + (t (symbolicate type "-NUM")))) + (type-reg (symbolicate (or complex type) "-REG"))) + `(define-vop (,name) + (:translate ,(symbolicate "%" name)) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + ,@(if set + `((value :scs (,type-reg) :target result)))) + (:arg-types * positive-fixnum ,@(if set `(,type-num))) + (:results (,(if set 'result 'value) :scs (,type-reg))) + (:temporary (:scs (non-descriptor-reg)) offset) + (:temporary (:scs (interior-reg)) lip) + (:result-types ,type-num) + (:generator 5 + (loadw offset object 0 instance-pointer-lowtag) + (inst srl offset n-widetag-bits offset) + (inst sll offset 2 offset) + (inst sub offset index offset) + (inst addi ,(* inc-offset-by n-word-bytes) + offset offset) + (inst add offset object lip) + ,@body))))) + (raw-instance (unsigned -1 nil) + (inst ldw (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) lip value)) + + (raw-instance (unsigned -1 t) + (inst stw value (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) lip) + (move value result)) + + (raw-instance (single -1 nil) + (inst li (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) offset) + (inst fldx offset lip value)) + + (raw-instance (single -1 t) + (inst li (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) offset) + (inst fstx value offset lip) + (unless (location= result value) + (inst funop :copy value result))) + + (raw-instance (double -2 nil) + (inst fldx object index value) + (inst fldx offset lip value)) + + (raw-instance (double -2 t) + (inst fldx offset lip value) + (inst fldx index object value) + (inst funop :copy value result)) + + (raw-instance (single -2 nil complex-single) + (inst li (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) offset) + (inst fldx offset lip (complex-single-reg-real-tn value)) + (inst li (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag) offset) + (inst fldx offset lip (complex-single-reg-imag-tn value))) + + (raw-instance (single -2 t complex-single) + (let ((value-real (complex-single-reg-real-tn value)) + (result-real (complex-single-reg-real-tn result))) + (inst li (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) offset) + (inst fstx value-real offset lip) + (unless (location= result-real value-real) + (inst funop :copy value-real result-real))) + (let ((value-imag (complex-single-reg-imag-tn value)) + (result-imag (complex-single-reg-imag-tn result))) + (inst li (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag) offset) + (inst fstx value-imag offset lip) + (unless (location= result-imag value-imag) + (inst funop :copy value-imag result-imag)))) + + (raw-instance (double -4 nil complex-double) + (let ((immediate-offset (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag))) + (inst li immediate-offset offset) + (inst fldx offset lip (complex-double-reg-real-tn value))) + (let ((immediate-offset (+ 4 (- (* (1+ instance-slots-offset) + n-word-bytes) instance-pointer-lowtag)))) + (inst li immediate-offset offset) + (inst fldx offset lip (complex-double-reg-real-tn value))) + (let ((immediate-offset (- (* (+ instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag))) + (inst li immediate-offset offset) + (inst fldx offset lip (complex-double-reg-imag-tn value))) + (let ((immediate-offset (+ 4 (- (* (+ instance-slots-offset 3) + n-word-bytes) instance-pointer-lowtag)))) + (inst li immediate-offset offset) + (inst fldx offset lip (complex-double-reg-imag-tn value)))) + + (raw-instance (double -4 t complex-double) + (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))) + (inst li immediate-offset offset) + (inst fldx offset lip value-real)) + (let ((immediate-offset (+ 4 (- (* (1+ instance-slots-offset) + n-word-bytes) instance-pointer-lowtag)))) + (inst li immediate-offset offset) + (inst fldx offset lip value-real)) + + (unless (location= result-real value-real) + (inst funop :copy value-real result-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))) + (inst li immediate-offset offset) + (inst fldx offset lip value-imag)) + + (let ((immediate-offset (+ 4 (- (* (+ instance-slots-offset 3) + n-word-bytes) instance-pointer-lowtag)))) + (inst li immediate-offset offset) + (inst fldx offset lip value-imag)) + (unless (location= result-imag value-imag) + (inst funop :copy value-imag result-imag)))))