Commit edcaad65 authored by Nikodemus Siivola's avatar Nikodemus Siivola
Browse files

1.0.24.10: raw slot support for HPPA 

 * Remove raw slot support workaround on hppa, VOPs implemented
   instead.

 * Patch by Larry Valkama.
parent f21346ee

src/code/defsetfs.lisp

+1 −11
Original line number Diff line number Diff line
@@ -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)

src/code/defstruct.lisp

+0 −3
Original line number Diff line number Diff line
@@ -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

src/code/target-defstruct.lisp

+30 −88
Original line number Diff line number Diff line
@@ -54,8 +54,6 @@ 
          slot-specs slot-values)

    instance))



#!-hppa

(progn

(defun %raw-instance-ref/word (instance index)

  (declare (type index index))

  (%raw-instance-ref/word instance index))
@@ -95,62 +93,6 @@ 
  (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)

  (declare (type index index))

  (%raw-ref-single vec index))



(defun %raw-ref-double (vec index)

  (declare (type index index))

  (%raw-ref-double vec index))



#!+long-float

(defun %raw-ref-long (vec index)

  (declare (type index index))

  (%raw-ref-long vec index))



(defun %raw-set-single (vec index val)

  (declare (type index index))

  (%raw-set-single vec index val))



(defun %raw-set-double (vec index val)

  (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



(defun %instance-layout (instance)

  (%instance-layout instance))

src/compiler/generic/vm-fndb.lisp

+1 −44
Original line number Diff line number Diff line
@@ -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))

src/compiler/hppa/cell.lisp

+147 −0
Original line number Diff line number Diff line
@@ -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)))))