From edcaad65452eee6bff2017941ef6c33b26a5a2b0 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 3 Jan 2009 15:39:38 +0000 Subject: [PATCH] 1.0.24.10: raw slot support for HPPA * Remove raw slot support workaround on hppa, VOPs implemented instead. * Patch by Larry Valkama. --- src/code/defsetfs.lisp | 12 +-- src/code/defstruct.lisp | 3 - src/code/target-defstruct.lisp | 118 ++++++++--------------------- src/compiler/generic/vm-fndb.lisp | 45 +----------- src/compiler/hppa/cell.lisp | 147 +++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 180 insertions(+), 147 deletions(-) diff --git a/src/code/defsetfs.lisp b/src/code/defsetfs.lisp index 94a240b..e066eca 100644 --- a/src/code/defsetfs.lisp +++ b/src/code/defsetfs.lisp @@ -39,22 +39,12 @@ ;;; from defstruct.lisp (in-package "SB!KERNEL") (defsetf %instance-ref %instance-set) -#!-hppa -(progn + (defsetf %raw-instance-ref/word %raw-instance-set/word) (defsetf %raw-instance-ref/single %raw-instance-set/single) (defsetf %raw-instance-ref/double %raw-instance-set/double) (defsetf %raw-instance-ref/complex-single %raw-instance-set/complex-single) (defsetf %raw-instance-ref/complex-double %raw-instance-set/complex-double) -) -#!+hppa -(progn -(defsetf %raw-ref-single %raw-set-single) -(defsetf %raw-ref-double %raw-set-double) - -(defsetf %raw-ref-complex-single %raw-set-complex-single) -(defsetf %raw-ref-complex-double %raw-set-complex-double) -) (defsetf %instance-layout %set-instance-layout) (defsetf %funcallable-instance-info %set-funcallable-instance-info) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 41f2ff1..ec8162f 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -272,9 +272,6 @@ (alignment 1 :type (integer 1 2) :read-only t)) (defvar *raw-slot-data-list* - #!+hppa - nil - #!-hppa (let ((double-float-alignment ;; white list of architectures that can load unaligned doubles: #!+(or x86 x86-64 ppc) 1 diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 4e9b596..5d580c7 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -54,103 +54,45 @@ slot-specs slot-values) instance)) -#!-hppa -(progn - (defun %raw-instance-ref/word (instance index) - (declare (type index index)) - (%raw-instance-ref/word instance index)) - (defun %raw-instance-set/word (instance index new-value) - (declare (type index index) - (type sb!vm:word new-value)) - (%raw-instance-set/word instance index new-value)) - - (defun %raw-instance-ref/single (instance index) - (declare (type index index)) - (%raw-instance-ref/single instance index)) - (defun %raw-instance-set/single (instance index new-value) - (declare (type index index) - (type single-float new-value)) - (%raw-instance-set/single instance index new-value)) - - (defun %raw-instance-ref/double (instance index) - (declare (type index index)) - (%raw-instance-ref/double instance index)) - (defun %raw-instance-set/double (instance index new-value) - (declare (type index index) - (type double-float new-value)) - (%raw-instance-set/double instance index new-value)) - - (defun %raw-instance-ref/complex-single (instance index) - (declare (type index index)) - (%raw-instance-ref/complex-single instance index)) - (defun %raw-instance-set/complex-single (instance index new-value) - (declare (type index index) - (type (complex single-float) new-value)) - (%raw-instance-set/complex-single instance index new-value)) - - (defun %raw-instance-ref/complex-double (instance index) - (declare (type index index)) - (%raw-instance-ref/complex-double instance index)) - (defun %raw-instance-set/complex-double (instance index new-value) - (declare (type index index) - (type (complex double-float) new-value)) - (%raw-instance-set/complex-double instance index new-value)) -) ; #!-HPPA - -#!+hppa -(progn -(defun %raw-ref-single (vec index) +(defun %raw-instance-ref/word (instance index) (declare (type index index)) - (%raw-ref-single vec index)) + (%raw-instance-ref/word instance index)) +(defun %raw-instance-set/word (instance index new-value) + (declare (type index index) + (type sb!vm:word new-value)) + (%raw-instance-set/word instance index new-value)) -(defun %raw-ref-double (vec index) +(defun %raw-instance-ref/single (instance index) (declare (type index index)) - (%raw-ref-double vec index)) + (%raw-instance-ref/single instance index)) +(defun %raw-instance-set/single (instance index new-value) + (declare (type index index) + (type single-float new-value)) + (%raw-instance-set/single instance index new-value)) -#!+long-float -(defun %raw-ref-long (vec index) +(defun %raw-instance-ref/double (instance index) (declare (type index index)) - (%raw-ref-long vec index)) + (%raw-instance-ref/double instance index)) +(defun %raw-instance-set/double (instance index new-value) + (declare (type index index) + (type double-float new-value)) + (%raw-instance-set/double instance index new-value)) -(defun %raw-set-single (vec index val) +(defun %raw-instance-ref/complex-single (instance index) (declare (type index index)) - (%raw-set-single vec index val)) + (%raw-instance-ref/complex-single instance index)) +(defun %raw-instance-set/complex-single (instance index new-value) + (declare (type index index) + (type (complex single-float) new-value)) + (%raw-instance-set/complex-single instance index new-value)) -(defun %raw-set-double (vec index val) +(defun %raw-instance-ref/complex-double (instance index) (declare (type index index)) - (%raw-set-double vec index val)) - -#!+long-float -(defun %raw-set-long (vec index val) - (declare (type index index)) - (%raw-set-long vec index val)) - -(defun %raw-ref-complex-single (vec index) - (declare (type index index)) - (%raw-ref-complex-single vec index)) - -(defun %raw-ref-complex-double (vec index) - (declare (type index index)) - (%raw-ref-complex-double vec index)) - -#!+long-float -(defun %raw-ref-complex-long (vec index) - (declare (type index index)) - (%raw-ref-complex-long vec index)) - -(defun %raw-set-complex-single (vec index val) - (declare (type index index)) - (%raw-set-complex-single vec index val)) - -(defun %raw-set-complex-double (vec index val) - (declare (type index index)) - (%raw-set-complex-double vec index val)) - -#!+long-float -(defun %raw-set-complex-long (vec index val) - (declare (type index index)) - (%raw-set-complex-long vec index val)) -) ; #!+HPPA + (%raw-instance-ref/complex-double instance index)) +(defun %raw-instance-set/complex-double (instance index new-value) + (declare (type index index) + (type (complex double-float) new-value)) + (%raw-instance-set/complex-double instance index new-value)) (defun %instance-layout (instance) (%instance-layout instance)) diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 28b263b..2c88571 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -126,8 +126,6 @@ (unsafe always-translatable)) (defknown %layout-invalid-error (t layout) nil) -#!-hppa -(progn (defknown %raw-instance-ref/word (instance index) sb!vm:word (flushable always-translatable)) (defknown %raw-instance-set/word (instance index sb!vm:word) sb!vm:word @@ -153,7 +151,7 @@ (defknown %raw-instance-set/complex-double (instance index (complex double-float)) (complex double-float) - (unsafe always-translatable))) + (unsafe always-translatable)) #!+(or x86 x86-64) (defknown %raw-instance-atomic-incf/word (instance index sb!vm:signed-word) sb!vm:word @@ -163,47 +161,6 @@ ;;; as their first argument (clarity and to match these DEFKNOWNs). ;;; We declare RAW-VECTOR as a primitive type so the VOP machinery ;;; will accept our VOPs as legitimate. --njf, 2004-08-10 -;;; -;;; These are only used on HPPA, since on HPPA implements raw slots in -;;; structures with an indirection vector; all other ports implement -;;; raw slots directly in the structure. --njf, 2006-06-02 -#!+hppa -(progn -(sb!xc:deftype raw-vector () '(simple-array sb!vm:word (*))) - -(sb!vm::!def-primitive-type-alias raw-vector - #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) - sb!vm::simple-array-unsigned-byte-32 - #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) - sb!vm::simple-array-unsigned-byte-64) - -(defknown %raw-ref-single (raw-vector index) single-float - (foldable flushable always-translatable)) -(defknown %raw-ref-double (raw-vector index) double-float - (foldable flushable always-translatable)) -#!+long-float -(defknown %raw-ref-long (raw-vector index) long-float - (foldable flushable always-translatable)) -(defknown %raw-set-single (raw-vector index single-float) single-float - (unsafe always-translatable)) -(defknown %raw-set-double (raw-vector index double-float) double-float - (unsafe always-translatable)) -#!+long-float -(defknown %raw-set-long (raw-vector index long-float) long-float - (unsafe always-translatable)) - -(defknown %raw-ref-complex-single (raw-vector index) (complex single-float) - (foldable flushable always-translatable)) -(defknown %raw-ref-complex-double (raw-vector index) (complex double-float) - (foldable flushable always-translatable)) - -(defknown %raw-set-complex-single (raw-vector index (complex single-float)) - (complex single-float) - (unsafe always-translatable)) -(defknown %raw-set-complex-double (raw-vector index (complex double-float)) - (complex double-float) - (unsafe always-translatable)) -) (defknown %raw-bits (t fixnum) sb!vm:word (foldable flushable)) 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))))) diff --git a/version.lisp-expr b/version.lisp-expr index 9dc536e..f4894c6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.24.9" +"1.0.24.10" -- 1.7.10.4