Commit 1d502618 authored by Nikodemus Siivola's avatar Nikodemus Siivola
Browse files

1.0.24.11: stack allocation support for HPPA 

 * Thiemo Seufer's MIPS stack allocation work and other things by him
   ported over to HPPA.

 * Patch by Larry Valkama.
parent edcaad65

src/assembly/hppa/array.lisp

+0 −27
Original line number Diff line number Diff line 
(in-package "SB!VM")



(define-assembly-routine

    (allocate-vector

     (:policy :fast-safe)

     (:translate allocate-vector)

     (:arg-types positive-fixnum

                 positive-fixnum

                 positive-fixnum))

    ((:arg type any-reg a0-offset)

     (:arg length any-reg a1-offset)

     (:arg words any-reg a2-offset)

     (:res result descriptor-reg a0-offset)



     (:temp ndescr non-descriptor-reg nl0-offset)

     (:temp vector descriptor-reg a3-offset))

  (pseudo-atomic ()

    (move alloc-tn vector)

    (inst dep other-pointer-lowtag 31 3 vector)

    (inst addi (* (1+ vector-data-offset) n-word-bytes) words ndescr)

    (inst dep 0 31 3 ndescr)

    (inst add ndescr alloc-tn alloc-tn)

    (inst srl type word-shift ndescr)

    (storew ndescr vector 0 other-pointer-lowtag)

    (storew length vector vector-length-slot other-pointer-lowtag))

  (move vector result))







;;;; Hash primitives



;;; FIXME: This looks kludgy bad and wrong.

src/compiler/generic/vm-ir2tran.lisp

+3 −3
Original line number Diff line number Diff line
@@ -175,7 +175,7 @@ 
;;; Stack allocation optimizers per platform support

;;;

;;; Platforms with stack-allocatable vectors

#!+(or mips x86 x86-64)

#!+(or hppa mips x86 x86-64)

(progn

  (defoptimizer (allocate-vector stack-allocate-result)

      ((type length words) node dx)
@@ -208,7 +208,7 @@ 
        (annotate-1-value-lvar arg)))))



;;; ...lists

#!+(or alpha mips ppc sparc x86 x86-64)

#!+(or alpha hppa mips ppc sparc x86 x86-64)

(progn

  (defoptimizer (list stack-allocate-result) ((&rest args) node dx)

    (declare (ignore node dx))
@@ -221,7 +221,7 @@ 
    t))



;;; ...conses

#!+(or mips x86 x86-64)

#!+(or hppa mips x86 x86-64)

(defoptimizer (cons stack-allocate-result) ((&rest args) node dx)

  (declare (ignore node dx))

  t)

src/compiler/hppa/alloc.lisp

+51 −7
Original line number Diff line number Diff line
@@ -71,6 +71,53 @@ 




;;;; Special purpose inline allocators.

;;; ALLOCATE-VECTOR

(define-vop (allocate-vector-on-heap)

  (:args (type :scs (unsigned-reg))

         (length :scs (any-reg))

         (words :scs (any-reg)))

  (:arg-types positive-fixnum

              positive-fixnum

              positive-fixnum)

  (:temporary (:sc non-descriptor-reg) bytes)

  (:results (result :scs (descriptor-reg) :from :load))

  (:policy :fast-safe)

  (:generator 100

    (inst addi (+ lowtag-mask

                  (* vector-data-offset n-word-bytes)) words bytes)

    (inst dep 0 31 n-lowtag-bits bytes)

    (pseudo-atomic ()

      (set-lowtag other-pointer-lowtag alloc-tn result)

      (inst add bytes alloc-tn alloc-tn)

      (storew type result 0 other-pointer-lowtag)

      (storew length result vector-length-slot other-pointer-lowtag))))



(define-vop (allocate-vector-on-stack)

  (:args (type :scs (unsigned-reg))

         (length :scs (any-reg))

         (words :scs (any-reg)))

  (:arg-types positive-fixnum

              positive-fixnum

              positive-fixnum)

  (:temporary (:sc non-descriptor-reg) bytes temp)

  (:results (result :scs (descriptor-reg) :from :load))

  (:policy :fast-safe)

  (:generator 100

    (inst addi (+ lowtag-mask

                  (* vector-data-offset n-word-bytes)) words bytes)

    (inst dep 0 31 n-lowtag-bits bytes)

    ;; FIXME: It would be good to check for stack overflow here.

    (pseudo-atomic ()

      (align-csp temp)

      (set-lowtag other-pointer-lowtag csp-tn result)

      (inst addi (* vector-data-offset n-word-bytes) csp-tn temp)

      (inst add bytes csp-tn csp-tn)

      (storew type result 0 other-pointer-lowtag)

      (storew length result vector-length-slot other-pointer-lowtag)

      (let ((loop (gen-label)))

        (emit-label loop)

        (inst comb :<> temp csp-tn loop :nullify t)

        (inst stwm zero-tn n-word-bytes temp)))))



(define-vop (allocate-code-object)

  (:args (boxed-arg :scs (any-reg))
@@ -159,16 +206,13 @@ 
(define-vop (fixed-alloc)

  (:args)

  (:info name words type lowtag stack-allocate-p)

  (:ignore name stack-allocate-p)

  (:ignore name)

  (:results (result :scs (descriptor-reg)))

  (:temporary (:scs (non-descriptor-reg)) temp)

  (:generator 4

    (pseudo-atomic (:extra (pad-data-block words))

      (inst move alloc-tn result)

      (inst dep lowtag 31 3 result)

      (when type

        (inst li (logior (ash (1- words) n-widetag-bits) type) temp)

        (storew temp result 0 lowtag)))))

    (with-fixed-allocation

      (result nil temp type words stack-allocate-p

       :lowtag lowtag :maybe-write t))))



(define-vop (var-alloc)

  (:args (extra :scs (any-reg)))

src/compiler/hppa/char.lisp

+4 −0
Original line number Diff line number Diff line
@@ -15,6 +15,7 @@ 


;;; Move a tagged char to an untagged representation.

(define-vop (move-to-character)

  (:note "character untagging")

  (:args (x :scs (any-reg descriptor-reg)))

  (:results (y :scs (character-reg)))

  (:generator 1
@@ -24,6 +25,7 @@ 


;;; Move an untagged char to a tagged representation.

(define-vop (move-from-character)

  (:note "character tagging")

  (:args (x :scs (character-reg)))

  (:results (y :scs (any-reg descriptor-reg)))

  (:generator 1
@@ -34,6 +36,7 @@ 


;;; Move untagged character values.

(define-vop (character-move)

  (:note "character move")

  (:args (x :target y

            :scs (character-reg)

            :load-if (not (location= x y))))
@@ -48,6 +51,7 @@ 


;;; Move untagged character args/return-values.

(define-vop (move-character-arg)

  (:note "character arg move")

  (:args (x :target y

            :scs (character-reg))

         (fp :scs (any-reg)

src/compiler/hppa/macros.lisp

+45 −14
Original line number Diff line number Diff line
@@ -54,6 +54,11 @@ 
    (:big-endian

     `(inst ldb (+ ,offset (1- n-word-bytes)) ,source ,target))))



(defmacro set-lowtag (tag src dst)

  `(progn

     (inst move ,src ,dst)

     (inst dep ,tag 31 n-lowtag-bits ,dst)))



;;; Macros to handle the fact that we cannot use the machine native call and

;;; return instructions.
@@ -118,23 +123,49 @@ 


;;;; Storage allocation:



(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)

(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code

                                  size dynamic-extent-p

                                  &key (lowtag other-pointer-lowtag)

                                       maybe-write)

                                 &body body)

  #!+sb-doc

  "Do stuff to allocate an other-pointer object of fixed Size with a single

word header having the specified Type-Code.  The result is placed in

Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used

by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably

initializes the object."

  (unless body

    (bug "empty &body in WITH-FIXED-ALLOCATION"))

  (declare (ignore flag-tn))

  (once-only ((result-tn result-tn) (temp-tn temp-tn)

              (type-code type-code) (size size))

    `(pseudo-atomic (:extra (pad-data-block ,size))

       (inst move alloc-tn ,result-tn)

       (inst dep other-pointer-lowtag 31 3 ,result-tn)

       (inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)

       (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)

       ,@body)))

              (type-code type-code) (size size)

              (lowtag lowtag))

    (let ((write-body `((inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)

                        (storew ,temp-tn ,result-tn 0 ,lowtag))))

      `(if ,dynamic-extent-p

         (pseudo-atomic ()

           (align-csp ,temp-tn)

           (set-lowtag ,lowtag csp-tn ,result-tn)

           (inst addi (pad-data-block ,size) csp-tn csp-tn)

           ,@(if maybe-write

               `((when ,type-code ,@write-body))

               write-body)

           ,@body)

         (pseudo-atomic (:extra (pad-data-block ,size))

           (set-lowtag ,lowtag alloc-tn ,result-tn)

           ,@(if maybe-write

               `((when ,type-code ,@write-body))

               write-body)

           ,@body)))))



;; is used for stack allocation of dynamic-extent objects

; FIX-lav, if using defun, atleast surround in assembly-form ? macro better ?

(defun align-csp (temp)

  (declare (ignore temp))

  (let ((aligned (gen-label)))

    (inst extru csp-tn 31 n-lowtag-bits zero-tn :<>)

    (inst b aligned :nullify t)

    (inst addi n-word-bytes csp-tn csp-tn)

    (storew zero-tn csp-tn -1)

    (emit-label aligned)))





;;;; Error Code