memory, and probably show better memory locality. (thanks to
David Lichteblau)
* optimization: DYNAMIC-EXTENT declarations for lists and closures
- are treated as requests for stack allocation on the x86-64
- platform.
+ are treated as requests for stack allocation on the x86-64 and
+ Alpha-32 platforms.
* contrib improvement: it's harder to cause SOCKET-CLOSE to close()
the wrong file descriptor; implementation of SOCKET-OPEN-P.
(thanks to Tony Martinez)
if [ "$sbcl_os" = "sunos" ] || [ "$sbcl_os" = "linux" ]; then
printf ' :linkage-table' >> $ltf
fi
+elif [ "$sbcl_arch" = "alpha" ]; then
+ printf ' :stack-allocatable-closures' >> $ltf
else
# Nothing need be done in this case, but sh syntax wants a placeholder.
echo > /dev/null
(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))
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(:policy :safe)
+ (:node-var node)
(:generator 0
(cond ((zerop num)
(move null-tn result))
(load-stack-tn temp ,tn)
temp))))
(storew reg ,list ,slot list-pointer-lowtag))))
- (let ((cons-cells (if star (1- num) num)))
- (pseudo-atomic (:extra (* (pad-data-block cons-size)
- cons-cells))
- (inst bis alloc-tn list-pointer-lowtag res)
+ (let* ((dx-p (awhen (sb!c::node-lvar node) (sb!c::lvar-dynamic-extent it)))
+ (cons-cells (if star (1- num) num))
+ (space (* (pad-data-block cons-size) cons-cells)))
+ (pseudo-atomic (:extra (if dx-p 0 space))
+ (cond (dx-p
+ (align-csp res)
+ (inst bis csp-tn list-pointer-lowtag res)
+ (inst lda csp-tn space csp-tn))
+ (t
+ (inst bis alloc-tn list-pointer-lowtag res)))
(move res ptr)
(dotimes (i (1- cons-cells))
(store-car (tn-ref-tn things) ptr)
(:ignore stack-allocate-p)
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (result :scs (descriptor-reg)))
+ (:node-var node)
(:generator 10
- (let ((size (+ length closure-info-offset)))
+ (let* ((size (+ length closure-info-offset))
+ (alloc-size (pad-data-block size))
+ (dx-p (node-stack-allocate-p node)))
(inst li
(logior (ash (1- size) n-widetag-bits) closure-header-widetag)
temp)
- (pseudo-atomic (:extra (pad-data-block size))
- (inst bis alloc-tn fun-pointer-lowtag result)
+ (pseudo-atomic (:extra (if dx-p 0 alloc-size))
+ (cond (dx-p
+ ;; no need to align CSP: FUN-POINTER-LOWTAG already has
+ ;; the corresponding bit set
+ (inst bis csp-tn fun-pointer-lowtag result)
+ (inst lda csp-tn alloc-size csp-tn))
+ (t
+ (inst bis alloc-tn fun-pointer-lowtag result)))
(storew temp result 0 fun-pointer-lowtag))
(storew function result closure-fun-slot fun-pointer-lowtag))))
(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg)
;;; Turn &MORE arg (context, count) into a list.
+(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args))
+ t)
+
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
(count-arg :target count :scs (any-reg)))
(:results (result :scs (descriptor-reg)))
(:translate %listify-rest-args)
(:policy :safe)
+ (:node-var node)
(:generator 20
- (let ((enter (gen-label))
- (loop (gen-label))
- (done (gen-label)))
+ (let* ((enter (gen-label))
+ (loop (gen-label))
+ (done (gen-label))
+ (dx-p (node-stack-allocate-p node))
+ (alloc-area-tn (if dx-p csp-tn alloc-tn)))
(move context-arg context)
(move count-arg count)
;; Check to see if there are any arguments.
;; We need to do this atomically.
(pseudo-atomic ()
+ ;; align CSP
+ (when dx-p (align-csp temp))
;; Allocate a cons (2 words) for each item.
- (inst bis alloc-tn list-pointer-lowtag result)
+ (inst bis alloc-area-tn list-pointer-lowtag result)
(move result dst)
(inst sll count 1 temp)
- (inst addq alloc-tn temp alloc-tn)
+ (inst addq alloc-area-tn temp alloc-area-tn)
(inst br zero-tn enter)
;; Store the current cons in the cdr of the previous cons.
(inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn)
(storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
,@body)))
+
+(defun align-csp (temp)
+ ;; is used for stack allocation of dynamic-extent objects
+ (let ((aligned (gen-label)))
+ (inst and csp-tn lowtag-mask temp)
+ (inst beq temp aligned)
+ (inst addq csp-tn n-word-bytes csp-tn)
+ (storew zero-tn csp-tn -1)
+ (emit-label aligned)))
\f
;;;; error code
(eval-when (:compile-toplevel :load-toplevel :execute)
(:generator 1
(move ptr csp-tn)))
-(define-vop (%%pop-dx)
- (:args (ptr :scs (any-reg)))
- (:ignore ptr)
- (:generator 1
- (bug "VOP %%POP-DX is not implemented.")))
-
-(define-vop (%%nip-dx)
- (:args (last-nipped-ptr :scs (any-reg) :target dest)
- (last-preserved-ptr :scs (any-reg) :target src)
- (moved-ptrs :scs (any-reg) :more t))
- (:results (r-moved-ptrs :scs (any-reg) :more t))
- (:temporary (:sc any-reg) src)
- (:temporary (:sc any-reg) dest)
- (:temporary (:sc non-descriptor-reg) temp)
- (:ignore r-moved-ptrs
- last-nipped-ptr last-preserved-ptr moved-ptrs
- src dest temp)
- (:generator 1
- (bug "VOP %%NIP-DX is not implemented.")))
-
(define-vop (%%nip-values)
(:args (last-nipped-ptr :scs (any-reg) :target dest)
(last-preserved-ptr :scs (any-reg) :target src)
;;; section.
;;; * OTHER-IMMEDIATE-0-LOWTAG are spaced 4 apart: various code wants to
;;; iterate through these
+;;; * Allocation code on Alpha wants lowtags for heap-allocated
+;;; objects to be odd.
;;; (These are just the ones we know about as of sbcl-0.7.1.22. There
;;; might easily be more, since these values have stayed highly
;;; constrained for more than a decade, an inviting target for
(let ((info (make-ir2-lvar *backend-t-primitive-type*)))
(setf (ir2-lvar-kind info) :delayed)
(setf (lvar-info leaves) info)
- #!+stack-grows-upward-not-downward
- (let ((tn (make-normal-tn *backend-t-primitive-type*)))
- (setf (ir2-lvar-locs info) (list tn)))
- #!+stack-grows-downward-not-upward
(setf (ir2-lvar-stack-pointer info)
(make-stack-pointer-tn)))))
(defoptimizer (%allocate-closures ir2-convert) ((leaves) call 2block)
- (let ((dx-p (lvar-dynamic-extent leaves))
- #!+stack-grows-upward-not-downward
- (first-closure nil))
+ (let ((dx-p (lvar-dynamic-extent leaves)))
(collect ((delayed))
- #!+stack-grows-downward-not-upward
(when dx-p
(vop current-stack-pointer call 2block
(ir2-lvar-stack-pointer (lvar-info leaves))))
(leaf-dx-p (and dx-p (leaf-dynamic-extent leaf))))
(vop make-closure call 2block entry (length closure)
leaf-dx-p tn)
- #!+stack-grows-upward-not-downward
- (when (and (not first-closure) leaf-dx-p)
- (setq first-closure tn))
(loop for what in closure and n from 0 do
(unless (and (lambda-var-p what)
(null (leaf-refs what)))
tn
(find-in-physenv what this-env)
n)))))))
- #!+stack-grows-upward-not-downward
- (when dx-p
- (emit-move call 2block first-closure
- (first (ir2-lvar-locs (lvar-info leaves)))))
(loop for (tn what n) in (delayed)
do (vop closure-init call 2block
tn what n))))
(r-refs (reference-tn-list results t)))
(aver (= (length info-args)
(template-info-arg-count template)))
- #!+stack-grows-downward-not-upward
(when (and lvar (lvar-dynamic-extent lvar))
(vop current-stack-pointer call block
(ir2-lvar-stack-pointer (lvar-info lvar))))
(vop reset-stack-pointer node block
(first (ir2-lvar-locs 2lvar))))
((lvar-dynamic-extent lvar)
- #!+stack-grows-downward-not-upward
(vop reset-stack-pointer node block
- (ir2-lvar-stack-pointer 2lvar))
- #!-stack-grows-downward-not-upward
- (vop %%pop-dx node block
- (first (ir2-lvar-locs 2lvar))))
+ (ir2-lvar-stack-pointer 2lvar)))
(t (bug "Trying to pop a not stack-allocated LVAR ~S."
lvar)))))
(nipped
(first (ir2-lvar-locs 2first))
(reference-tn-list moved-tns nil))
- ((reference-tn-list moved-tns t))))
- #!-stack-grows-downward-not-upward
- (nip-unaligned (nipped)
- (vop* %%nip-dx node block
- (nipped
- (first (ir2-lvar-locs 2first))
- (reference-tn-list moved-tns nil))
((reference-tn-list moved-tns t)))))
(cond ((eq (ir2-lvar-kind 2after) :unknown)
(nip-aligned (first (ir2-lvar-locs 2after))))
((lvar-dynamic-extent after)
- #!+stack-grows-downward-not-upward
- (nip-aligned (ir2-lvar-stack-pointer 2after))
- #!-stack-grows-downward-not-upward
- (nip-unaligned (ir2-lvar-stack-pointer 2after)))
+ (nip-aligned (ir2-lvar-stack-pointer 2after)))
(t
(bug "Trying to nip a not stack-allocated LVAR ~S." after))))))
(res (lvar-result-tns
lvar
(list (primitive-type (specifier-type 'list))))))
- #!+stack-grows-downward-not-upward
(when (and lvar (lvar-dynamic-extent lvar))
(vop current-stack-pointer node block
(ir2-lvar-stack-pointer (lvar-info lvar))))
(setf (ir2-lvar-kind info) :delayed))
(t (let ((tn (make-normal-tn (ir2-lvar-primitive-type info))))
(setf (ir2-lvar-locs info) (list tn))
- #!+stack-grows-downward-not-upward
(when (lvar-dynamic-extent lvar)
(setf (ir2-lvar-stack-pointer info)
(make-stack-pointer-tn)))))))
(setf (lvar-info lvar) info)
(when (lvar-dynamic-extent lvar)
(aver (proper-list-of-length-p types 1))
- #!+stack-grows-downward-not-upward
(setf (ir2-lvar-stack-pointer info)
(make-stack-pointer-tn))))
(ltn-annotate-casts lvar)
;; these TNs primitive type is only based on the proven type
;; information.
(locs nil :type list)
- #!+stack-grows-downward-not-upward
(stack-pointer nil :type (or tn null)))
-;; For upward growing stack start of stack block and start of object
-;; differ only by lowtag.
-#!-stack-grows-downward-not-upward
-(defmacro ir2-lvar-stack-pointer (2lvar)
- `(first (ir2-lvar-locs ,2lvar)))
(defprinter (ir2-lvar)
kind
(defun-with-dx dxcaller (&rest rest)
(declare (dynamic-extent rest))
(callee rest))
-
(assert (= (dxcaller 1 2 3 4 5 6 7) 22))
+(defun-with-dx dxcaller-align-1 (x &rest rest)
+ (declare (dynamic-extent rest))
+ (+ x (callee rest)))
+(assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7) 39))
+(assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7 8) 40))
+
;;; %NIP-VALUES
(defun-with-dx test-nip-values ()
(flet ((bar (x &rest y)
(opaque-identity :bar)
z)))
\f
+;;; alignment
+(defvar *x*)
+(defun-with-dx test-alignment-dx-list (form)
+ (multiple-value-prog1 (eval form)
+ (let ((l (list 1 2 3 4)))
+ (declare (dynamic-extent l))
+ (setq *x* (copy-list l)))))
+(dotimes (n 64)
+ (let* ((res (loop for i below n collect i))
+ (form `(values ,@res)))
+ (assert (equal (multiple-value-list (test-alignment-dx-list form)) res))
+ (assert (equal *x* '(1 2 3 4)))))
+
+
+
+\f
(defmacro assert-no-consing (form &optional times)
`(%assert-no-consing (lambda () ,form ,times)))
(defun %assert-no-consing (thunk &optional times)
(funcall thunk))
(assert (< (- (get-bytes-consed) before) times))))
-#+(or x86 x86-64)
+#+(or x86 x86-64 alpha)
(progn
(assert-no-consing (dxlength 1 2 3))
(assert-no-consing (dxlength t t t t t t))
;;; 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".)
-"0.9.1.51"
+"0.9.1.52"
projects / sbcl.git / commitdiff