;;; 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)
(: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)))
+ (let ((unboxed-elements-p (and (sc-is type immediate)
+ (/= (tn-value type)
+ simple-vector-widetag))))
+ (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)
+ (unless unboxed-elements-p
+ (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))
+ (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)
+ (unless unboxed-elements-p
+ (inst xor zero zero)
+ (inst rep)
+ (inst stos zero)))))
+
+(in-package "SB!C")
-(in-package :sb!c)
(defoptimizer (allocate-vector stack-allocate-result)
((type length words) node)
(ecase (policy node stack-allocate-vector)
(dolist (arg args)
(annotate-1-value-lvar arg))))
-(in-package :sb!vm)
+
+(in-package "SB!VM")
;;;
(define-vop (allocate-code-object)
(: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)
(: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 (= lowtag list-pointer-lowtag) (policy node (< speed 3)))
+ (let ((dst
+ #.(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)
+ (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