0.9.1.48:

	Implement (most of) the dynamic-extent vops on x86-64.
	... no support for vectors yet.

diff --git a/NEWS b/NEWS
index 79e1224..b0a8820 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -34,6 +34,9 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1:
   * optimization: structure instances with raw slots now use less
     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.
   * contrib improvement: it's harder to cause SOCKET-CLOSE to close()
     the wrong file descriptor; implementation of SOCKET-OPEN-P.
     (thanks to Tony Martinez)

diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp
index cf91584..f15e19e 100644 (file)
--- a/src/compiler/x86-64/alloc.lisp
+++ b/src/compiler/x86-64/alloc.lisp
@@ -12,6 +12,10 @@
 (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))
@@ -40,7 +44,9 @@
                     (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)
@@ -111,14 +117,13 @@
 (define-vop (make-closure)
   (:args (function :to :save :scs (descriptor-reg)))
   (:info length stack-allocate-p)
-  (:ignore stack-allocate-p)
   (:temporary (:sc any-reg) temp)
   (:results (result :scs (descriptor-reg)))
   (:node-var node)
   (:generator 10
-   (pseudo-atomic
+   (maybe-pseudo-atomic stack-allocate-p
     (let ((size (+ length closure-info-offset)))
-      (allocation result (pad-data-block size) node)
+      (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)

diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp
index abff23f..e1a1267 100644 (file)
--- a/src/compiler/x86-64/call.lisp
+++ b/src/compiler/x86-64/call.lisp
@@ -1248,8 +1248,10 @@
    (inst mov value
         (make-ea :qword :base object :disp (- (* index n-word-bytes))))))
 
-
 ;;; Turn more arg (context, count) into a list.
+(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args))
+  t)
+
 (define-vop (listify-rest-args)
   (:translate %listify-rest-args)
   (:policy :safe)
@@ -1265,15 +1267,16 @@
   (:generator 20
     (let ((enter (gen-label))
          (loop (gen-label))
-         (done (gen-label)))
+         (done (gen-label))
+         (stack-allocate-p (node-stack-allocate-p node)))
       (move src context)
       (move rcx count)
       ;; Check to see whether there are no args, and just return NIL if so.
       (inst mov result nil-value)
       (inst jecxz done)
       (inst lea dst (make-ea :qword :index rcx :scale 2))
-      (pseudo-atomic
-       (allocation dst dst node)
+      (maybe-pseudo-atomic stack-allocate-p
+       (allocation dst dst node stack-allocate-p)
        (inst lea dst (make-ea :byte :base dst :disp list-pointer-lowtag))
        ;; Convert the count into a raw value, so that we can use the
        ;; LOOP instruction.

diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 625b496..29601b5 100644 (file)
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -124,6 +124,14 @@
 ;;; node-var then it is used to make an appropriate speed vs size
 ;;; decision.
 
+(defun allocation-dynamic-extent (alloc-tn size)
+  (inst sub rsp-tn size)
+  ;; see comment in x86/macros.lisp implementation of this
+  (inst and rsp-tn #.(lognot lowtag-mask))
+  (aver (not (location= alloc-tn rsp-tn)))
+  (inst mov alloc-tn rsp-tn)
+  (values))
+
 ;;; This macro should only be used inside a pseudo-atomic section,
 ;;; which should also cover subsequent initialization of the
 ;;; object.
@@ -136,8 +144,11 @@
   (inst pop alloc-tn)
   (values))
 
-(defun allocation (alloc-tn size &optional ignored)
+(defun allocation (alloc-tn size &optional ignored dynamic-extent)
   (declare (ignore ignored))
+  (when dynamic-extent
+    (allocation-dynamic-extent alloc-tn size)
+    (return-from allocation (values)))
   (let ((NOT-INLINE (gen-label))
        (DONE (gen-label))
        ;; Yuck.
@@ -258,6 +269,12 @@
 ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
 ;;; the C flag after the shift to see whether you were interrupted.
 
+;;; FIXME: THIS NAME IS BACKWARDS!
+(defmacro maybe-pseudo-atomic (really-p &body body)
+  `(if ,really-p
+       (progn ,@body)
+       (pseudo-atomic ,@body)))
+
 (defmacro pseudo-atomic (&rest forms)
   (with-unique-names (label)
     `(let ((,label (gen-label)))

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index cb436c3..ece03b1 100644 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -100,7 +100,7 @@
       (funcall thunk))
     (assert (< (- (get-bytes-consed) before) times))))
 
-#+x86
+#+(or x86 x86-64)
 (progn
   (assert-no-consing (dxlength 1 2 3))
   (assert-no-consing (dxlength t t t t t t))

diff --git a/version.lisp-expr b/version.lisp-expr
index 012990a..0391c3e 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; 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.47"
+"0.9.1.48"