From 1d5026183c434517a84d03239804a44ebf8cfd1e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 3 Jan 2009 15:41:58 +0000 Subject: [PATCH] 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. --- src/assembly/hppa/array.lisp | 27 ---------------- src/compiler/generic/vm-ir2tran.lisp | 6 ++-- src/compiler/hppa/alloc.lisp | 58 +++++++++++++++++++++++++++++---- src/compiler/hppa/char.lisp | 4 +++ src/compiler/hppa/macros.lisp | 59 ++++++++++++++++++++++++++-------- src/compiler/hppa/vm.lisp | 19 ++++++----- version.lisp-expr | 2 +- 7 files changed, 113 insertions(+), 62 deletions(-) diff --git a/src/assembly/hppa/array.lisp b/src/assembly/hppa/array.lisp index 84638ab..5afb42b 100644 --- a/src/assembly/hppa/array.lisp +++ b/src/assembly/hppa/array.lisp @@ -1,32 +1,5 @@ (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. diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp index 25e3ed4..2cbe33b 100644 --- a/src/compiler/generic/vm-ir2tran.lisp +++ b/src/compiler/generic/vm-ir2tran.lisp @@ -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) diff --git a/src/compiler/hppa/alloc.lisp b/src/compiler/hppa/alloc.lisp index 779234f..30ce93c 100644 --- a/src/compiler/hppa/alloc.lisp +++ b/src/compiler/hppa/alloc.lisp @@ -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))) diff --git a/src/compiler/hppa/char.lisp b/src/compiler/hppa/char.lisp index aec3e69..0a9d310 100644 --- a/src/compiler/hppa/char.lisp +++ b/src/compiler/hppa/char.lisp @@ -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) diff --git a/src/compiler/hppa/macros.lisp b/src/compiler/hppa/macros.lisp index 52b4e4b..0360de0 100644 --- a/src/compiler/hppa/macros.lisp +++ b/src/compiler/hppa/macros.lisp @@ -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")) +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." + (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 diff --git a/src/compiler/hppa/vm.lisp b/src/compiler/hppa/vm.lisp index 2f5c1d0..3ead719 100644 --- a/src/compiler/hppa/vm.lisp +++ b/src/compiler/hppa/vm.lisp @@ -102,8 +102,7 @@ "-SC-NUMBER")))) (list* `(define-storage-class ,sc-name ,index ,@(cdr class)) - `(defconstant ,constant-name ,index) - `(export ',constant-name) + `(def!constant ,constant-name ,index) forms))) (index 0 (1+ index)) (classes classes (cdr classes))) @@ -303,20 +302,20 @@ ;;; The SC numbers for register and stack arguments/return values. ;;; -(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) -(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) -(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) +(def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) +(def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) +(def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) (eval-when (:compile-toplevel :load-toplevel :execute) ;;; Offsets of special stack frame locations -(defconstant ocfp-save-offset 0) -(defconstant lra-save-offset 1) -(defconstant nfp-save-offset 2) +(def!constant ocfp-save-offset 0) +(def!constant lra-save-offset 1) +(def!constant nfp-save-offset 2) ;;; The number of arguments/return values passed in registers. ;;; -(defconstant register-arg-count 6) +(def!constant register-arg-count 6) ;;; Names to use for the argument registers. ;;; @@ -335,7 +334,7 @@ *register-arg-offsets*)) ;;; This is used by the debugger. -(defconstant single-value-return-byte-offset 4) +(def!constant single-value-return-byte-offset 4) ;;; This function is called by debug output routines that want a pretty name ;;; for a TN's location. It returns a thing that can be printed with PRINC. diff --git a/version.lisp-expr b/version.lisp-expr index f4894c6..2182fd1 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.10" +"1.0.24.11" -- 1.7.10.4