(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))
-
-
-\f
;;;; Hash primitives
;;; FIXME: This looks kludgy bad and wrong.
;;; 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)
(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))
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)
\f
;;;; 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))
(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)))
;;; 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
;;; 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
;;; Move untagged character values.
(define-vop (character-move)
+ (:note "character move")
(:args (x :target y
:scs (character-reg)
:load-if (not (location= x y))))
;;; 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)
(: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.
\f
;;;; 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)))
\f
;;;; Error Code
"-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)))
;;; 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.
;;;
*register-arg-offsets*))
;;; This is used by the debugger.
-(defconstant single-value-return-byte-offset 4)
+(def!constant single-value-return-byte-offset 4)
\f
;;; 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.
;;; 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"
projects / sbcl.git / commitdiff