(in-package "SB!VM")
\f
;;;; LIST and LIST*
+(defoptimizer (list stack-allocate-result) ((&rest args))
+ (not (null args)))
+(defoptimizer (list* stack-allocate-result) ((&rest args))
+ (not (null (rest args))))
(define-vop (list-or-list*)
(:args (things :more t))
(storew reg ,list ,slot list-pointer-lowtag))))
(let ((cons-cells (if star (1- num) num)))
(pseudo-atomic
- (allocation res (* (pad-data-block cons-size) cons-cells) node)
+ (allocation res (* (pad-data-block cons-size) cons-cells) node
+ (awhen (sb!c::node-lvar node) (sb!c::lvar-dynamic-extent it)))
(inst lea res
(make-ea :byte :base res :disp list-pointer-lowtag))
(move ptr res)
\f
;;;; special-purpose inline allocators
-(define-vop (allocate-code-object)
- (:args (boxed-arg :scs (any-reg) :target boxed)
- (unboxed-arg :scs (any-reg) :target unboxed))
- (:results (result :scs (descriptor-reg)))
- (:temporary (:sc unsigned-reg :from :eval) temp)
- (:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
- (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
+;;; ALLOCATE-VECTOR
+(define-vop (allocate-vector-on-heap)
+ (:args (type :scs (unsigned-reg))
+ (length :scs (any-reg))
+ (words :scs (any-reg)))
+ (:results (result :scs (descriptor-reg) :from :load))
+ (:arg-types positive-fixnum
+ positive-fixnum
+ positive-fixnum)
+ (:policy :fast-safe)
(:generator 100
- (move boxed boxed-arg)
- (inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
- (inst and boxed (lognot lowtag-mask))
- (move unboxed unboxed-arg)
- (inst shr unboxed word-shift)
- (inst add unboxed lowtag-mask)
- (inst and unboxed (lognot lowtag-mask))
+ (inst lea result (make-ea :byte :base words :disp
+ (+ (1- (ash 1 n-lowtag-bits))
+ (* vector-data-offset n-word-bytes))))
+ (inst and result (lognot lowtag-mask))
(pseudo-atomic
- ;; comment from CMU CL code:
- ;; now loading code into static space cause it can't move
- ;;
- ;; KLUDGE: What? What's all the cruft about saving fixups for then?
- ;; I think what's happened is that ALLOCATE-CODE-OBJECT is the basic
- ;; CMU CL primitive; this ALLOCATE-CODE-OBJECT was hacked for
- ;; static space only in a simple-minded port to the X86; and then
- ;; in an attempt to improve the port to the X86,
- ;; ALLOCATE-DYNAMIC-CODE-OBJECT was defined. If that's right, I'd like
- ;; to know why not just go back to the basic CMU CL behavior of
- ;; ALLOCATE-CODE-OBJECT, where it makes a relocatable code object.
- ;; -- WHN 19990916
- ;;
- ;; FIXME: should have a check for overflow of static space
- (load-symbol-value temp *static-space-free-pointer*)
- (inst lea result (make-ea :byte :base temp :disp other-pointer-lowtag))
- (inst add temp boxed)
- (inst add temp unboxed)
- (store-symbol-value temp *static-space-free-pointer*)
- (inst shl boxed (- n-widetag-bits word-shift))
- (inst or boxed code-header-widetag)
- (storew boxed result 0 other-pointer-lowtag)
- (storew unboxed result code-code-size-slot other-pointer-lowtag)
- (inst mov temp nil-value)
- (storew temp result code-entry-points-slot other-pointer-lowtag))
- (storew temp result code-debug-info-slot other-pointer-lowtag)))
+ (allocation result result)
+ (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
+ (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) :target ecx))
+ (:temporary (:sc any-reg :offset ecx-offset :from (:argument 2)) ecx)
+ (:temporary (:sc any-reg :offset eax-offset :from (:argument 2)) zero)
+ (:temporary (:sc any-reg :offset edi-offset :from (:argument 0)) res)
+ (:results (result :scs (descriptor-reg) :from :load))
+ (:arg-types positive-fixnum
+ positive-fixnum
+ positive-fixnum)
+ (:translate allocate-vector)
+ (:policy :fast-safe)
+ (:node-var node)
+ (:generator 100
+ (inst lea result (make-ea :byte :base words :disp
+ (+ (1- (ash 1 n-lowtag-bits))
+ (* vector-data-offset n-word-bytes))))
+ (inst and result (lognot lowtag-mask))
+ ;; FIXME: It would be good to check for stack overflow here.
+ (move ecx words)
+ (inst shr ecx n-fixnum-tag-bits)
+ (allocation result result node t)
+ (inst cld)
+ (inst lea res
+ (make-ea :byte :base result :disp (* vector-data-offset n-word-bytes)))
+ (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
+ (storew type result 0 other-pointer-lowtag)
+ (storew length result vector-length-slot other-pointer-lowtag)
+ (inst xor zero zero)
+ (inst rep)
+ (inst stos zero)))
+
+(in-package :sb!c)
+(defoptimizer (allocate-vector stack-allocate-result)
+ ((type length words) node)
+ (ecase (policy node stack-allocate-vector)
+ (0 nil)
+ ((1 2)
+ ;; a vector object should fit in one page
+ (values-subtypep (lvar-derived-type words)
+ (load-time-value
+ (specifier-type `(integer 0 ,(- (/ sb!vm::*backend-page-size*
+ sb!vm:n-word-bytes)
+ sb!vm:vector-data-offset))))))
+ (3 t)))
+
+(defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy)
+ (let ((args (basic-combination-args call))
+ (template (template-or-lose (if (awhen (node-lvar call)
+ (lvar-dynamic-extent it))
+ 'sb!vm::allocate-vector-on-stack
+ 'sb!vm::allocate-vector-on-heap))))
+ (dolist (arg args)
+ (setf (lvar-info arg)
+ (make-ir2-lvar (primitive-type (lvar-type arg)))))
+ (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
+ (ltn-default-call call)
+ (return-from allocate-vector-ltn-annotate-optimizer (values)))
+ (setf (basic-combination-info call) template)
+ (setf (node-tail-p call) nil)
-(define-vop (allocate-dynamic-code-object)
+ (dolist (arg args)
+ (annotate-1-value-lvar arg))))
+(in-package :sb!vm)
+
+;;;
+(define-vop (allocate-code-object)
(:args (boxed-arg :scs (any-reg) :target boxed)
(unboxed-arg :scs (any-reg) :target unboxed))
(:results (result :scs (descriptor-reg) :from :eval))
(with-fixed-allocation (result fdefn-widetag fdefn-size node)
(storew name result fdefn-name-slot other-pointer-lowtag)
(storew nil-value result fdefn-fun-slot other-pointer-lowtag)
- (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
+ (storew (make-fixup "undefined_tramp" :foreign)
result fdefn-raw-addr-slot other-pointer-lowtag))))
(define-vop (make-closure)
(:args (function :to :save :scs (descriptor-reg)))
- (:info length)
+ (:info length stack-allocate-p)
(:temporary (:sc any-reg) temp)
(:results (result :scs (descriptor-reg)))
(:node-var node)
(:generator 10
- (pseudo-atomic
- (let ((size (+ length closure-info-offset)))
- (allocation result (pad-data-block size) node)
- (inst lea result
- (make-ea :byte :base result :disp fun-pointer-lowtag))
- (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
- result 0 fun-pointer-lowtag))
+ (maybe-pseudo-atomic stack-allocate-p
+ (let ((size (+ length closure-info-offset)))
+ (allocation result (pad-data-block size) node
+ stack-allocate-p)
+ (inst lea result
+ (make-ea :byte :base result :disp fun-pointer-lowtag))
+ (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
+ result 0 fun-pointer-lowtag))
(loadw temp function closure-fun-slot fun-pointer-lowtag)
(storew temp result closure-fun-slot fun-pointer-lowtag))))
(:node-var node)
(:generator 10
(with-fixed-allocation
- (result value-cell-header-widetag value-cell-size node))
- (storew value result value-cell-value-slot other-pointer-lowtag)))
+ (result value-cell-header-widetag value-cell-size node)
+ (storew value result value-cell-value-slot other-pointer-lowtag))))
\f
;;;; automatic allocators for primitive objects
(inst lea result (make-ea :byte :base result :disp lowtag))
(storew header result 0 lowtag))))
-(define-vop (make-symbol)
- (:policy :fast-safe)
- (:translate make-symbol)
- (:args (name :scs (descriptor-reg) :to :eval))
- (:temporary (:sc unsigned-reg :from :eval) temp)
- (:results (result :scs (descriptor-reg) :from :argument))
- (:node-var node)
- (:generator 37
- (with-fixed-allocation (result symbol-header-widetag symbol-size node)
- (storew name result symbol-name-slot other-pointer-lowtag)
- (storew unbound-marker-widetag
- result
- symbol-value-slot
- other-pointer-lowtag)
- ;; Set up a random hash value for the symbol. Perhaps the object
- ;; address could be used for even faster and smaller code!
- ;; FIXME: We don't mind the symbol hash not being repeatable, so
- ;; we might as well add in the object address here, too. (Adding entropy
- ;; is good, even if ANSI doesn't understand that.)
- (inst imul temp
- (make-fixup (extern-alien-name "fast_random_state") :foreign)
- 1103515245)
- (inst add temp 12345)
- (inst mov (make-fixup (extern-alien-name "fast_random_state") :foreign)
- temp)
- ;; We want a positive fixnum for the hash value, so discard the LS bits.
- ;;
- ;; FIXME: OK, who wants to tell me (CSR) why these two
- ;; instructions aren't replaced by (INST AND TEMP #x8FFFFFFC)?
- ;; Are the following two instructions actually faster? Does the
- ;; difference in behaviour really matter?
- (inst shr temp 1)
- (inst and temp #xfffffffc)
- (storew temp result symbol-hash-slot other-pointer-lowtag)
- (storew nil-value result symbol-plist-slot other-pointer-lowtag)
- (storew nil-value result symbol-package-slot other-pointer-lowtag))))
+