(in-package "SB!VM")
\f
-;;;; LIST and LIST*
+;;;; CONS, LIST and LIST*
+(defoptimizer (cons stack-allocate-result) ((&rest args))
+ t)
(defoptimizer (list stack-allocate-result) ((&rest args))
(not (null args)))
(defoptimizer (list* stack-allocate-result) ((&rest args))
;;; ALLOCATE-VECTOR
(define-vop (allocate-vector-on-heap)
- (:args (type :scs (unsigned-reg))
- (length :scs (any-reg))
- (words :scs (any-reg)))
+ (:args (type :scs (unsigned-reg immediate))
+ (length :scs (any-reg immediate))
+ (words :scs (any-reg immediate)))
(:results (result :scs (descriptor-reg) :from :load))
(:arg-types positive-fixnum
positive-fixnum
positive-fixnum)
(:policy :fast-safe)
(: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))
- (pseudo-atomic
- (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))))
+ (let ((size (sc-case words
+ (immediate
+ (logandc2 (+ (fixnumize (tn-value words))
+ (+ (1- (ash 1 n-lowtag-bits))
+ (* vector-data-offset n-word-bytes)))
+ lowtag-mask))
+ (t
+ (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))
+ result))))
+ (pseudo-atomic
+ (allocation result size)
+ (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
+ (sc-case type
+ (immediate
+ (aver (typep (tn-value type) '(unsigned-byte 8)))
+ (storeb (tn-value type) result 0 other-pointer-lowtag))
+ (t
+ (storew type result 0 other-pointer-lowtag)))
+ (sc-case length
+ (immediate
+ (let ((fixnum-length (fixnumize (tn-value length))))
+ (typecase fixnum-length
+ ((unsigned-byte 8)
+ (storeb fixnum-length result
+ vector-length-slot other-pointer-lowtag))
+ (t
+ (storew fixnum-length result
+ vector-length-slot other-pointer-lowtag)))))
+ (t
+ (storew length result vector-length-slot other-pointer-lowtag)))))))
(define-vop (allocate-vector-on-stack)
- (:args (type :scs (unsigned-reg))
+ (:args (type :scs (unsigned-reg immediate))
(length :scs (any-reg))
(words :scs (any-reg) :target ecx))
(:temporary (:sc any-reg :offset ecx-offset :from (:argument 2)) ecx)
(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)
+ (sc-case type
+ (immediate
+ (aver (typep (tn-value type) '(unsigned-byte 8)))
+ (storeb (tn-value type) result 0 other-pointer-lowtag))
+ (t
+ (storew type result 0 other-pointer-lowtag)))
(storew length result vector-length-slot other-pointer-lowtag)
(inst xor zero zero)
(inst rep)
(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))
- (storew result result closure-self-slot fun-pointer-lowtag)
(loadw temp function closure-fun-slot fun-pointer-lowtag)
(storew temp result closure-fun-slot fun-pointer-lowtag))))
(define-vop (make-value-cell)
(:args (value :scs (descriptor-reg any-reg) :to :result))
(:results (result :scs (descriptor-reg) :from :eval))
+ (:info stack-allocate-p)
(:node-var node)
(:generator 10
(with-fixed-allocation
- (result value-cell-header-widetag value-cell-size node)
+ (result value-cell-header-widetag value-cell-size node stack-allocate-p)
(storew value result value-cell-value-slot other-pointer-lowtag))))
\f
;;;; automatic allocators for primitive objects
(:generator 1
(inst mov result unbound-marker-widetag)))
+(define-vop (make-funcallable-instance-tramp)
+ (:args)
+ (:results (result :scs (any-reg)))
+ (:generator 1
+ (inst lea result (make-fixup "funcallable_instance_tramp" :foreign))))
+
(define-vop (fixed-alloc)
(:args)
- (:info name words type lowtag)
+ (:info name words type lowtag stack-allocate-p)
(:ignore name)
(:results (result :scs (descriptor-reg)))
(:node-var node)
(:generator 50
- (pseudo-atomic
- (allocation result (pad-data-block words) node)
- (inst lea result (make-ea :byte :base result :disp lowtag))
- (when type
- (storew (logior (ash (1- words) n-widetag-bits) type)
- result
- 0
- lowtag)))))
+ ;; We special case the allocation of conses, because they're
+ ;; extremely common and because the pseudo-atomic sequence on x86
+ ;; is relatively heavyweight. However, if the user asks for top
+ ;; speed, we accomodate him. The primary reason that we don't
+ ;; also check for (< SPEED SPACE) is because we want the space
+ ;; savings that these out-of-line allocation routines bring whilst
+ ;; compiling SBCL itself. --njf, 2006-07-08
+ (if (and (not stack-allocate-p)
+ (= lowtag list-pointer-lowtag) (policy node (< speed 3)))
+ (let ((dst
+ ;; FIXME: out-of-line dx-allocation
+ #.(loop for offset in *dword-regs*
+ collect `(,offset
+ ',(intern (format nil "ALLOCATE-CONS-TO-~A"
+ (svref *dword-register-names*
+ offset)))) into cases
+ finally (return `(case (tn-offset result)
+ ,@cases)))))
+ (aver (null type))
+ (inst call (make-fixup dst :assembly-routine)))
+ (pseudo-atomic
+ (allocation result (pad-data-block words) node stack-allocate-p)
+ (inst lea result (make-ea :byte :base result :disp lowtag))
+ (when type
+ (storew (logior (ash (1- words) n-widetag-bits) type)
+ result
+ 0
+ lowtag))))))
(define-vop (var-alloc)
(:args (extra :scs (any-reg)))
(allocation result bytes node)
(inst lea result (make-ea :byte :base result :disp lowtag))
(storew header result 0 lowtag))))
-
-
projects / sbcl.git / blobdiff