From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Wed, 26 Sep 2007 15:44:23 +0000 (+0000)
Subject: 1.0.10.5: dynamic-extent CONS
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=66cff1e1319861c080d563359afea284614b3a7f;p=sbcl.git

1.0.10.5: dynamic-extent CONS

* Extend EMIT-FIXED-ALLOC to support stack-allocation.

* Appropriate DEFOPTIMIZER for CONS.

Note: it seems like it should be a simple matter to support stack
allocation of all primitive objects allocated using the :ALLOC-TRANS
framework.
---

diff --git a/NEWS b/NEWS
index 447969d..d5d51ba 100644
--- a/NEWS
+++ b/NEWS
@@ -21,6 +21,9 @@ changes in sbcl-1.0.10 relative to sbcl-1.0.9:
   * optimization: UNION and NUNION are now O(N+M) for large
     inputs as long as the :TEST function is one of EQ, EQL, EQUAL, or
     EQUALP.
+  * enhancement: CONS can now stack-allocate on x86 and
+    x86-64. (Earlier LIST and LIST* supported stack-allocation, but
+    CONS did not:)
   * enhancement: DEFINE-MODIFY-MACRO lambda-list information is
     now more readable in environments like Slime which display it.
     (thanks to Tobias C. Rittweiler)  
diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS
index 45b5463..44663ef 100644
--- a/OPTIMIZATIONS
+++ b/OPTIMIZATIONS
@@ -411,12 +411,6 @@ all three comparisons or b) eliminated the necessity of the MOV(s)
 altogether.  The former option is probably easier than the latter.
 
 --------------------------------------------------------------------------------
-#37
-
-Dynamic extent allocation doesn't currently work for one-element lists,
-since there's a source transform from (LIST X) to (CONS X NIL).
-
---------------------------------------------------------------------------------
 #38
 
 (setf (subseq s1 start1 end1) (subseq s2 start2 end1))
diff --git a/src/compiler/alpha/alloc.lisp b/src/compiler/alpha/alloc.lisp
index 71d0536..878fd58 100644
--- a/src/compiler/alpha/alloc.lisp
+++ b/src/compiler/alpha/alloc.lisp
@@ -171,8 +171,8 @@
 
 (define-vop (fixed-alloc)
   (:args)
-  (:info name words type lowtag)
-  (:ignore name)
+  (:info name words type lowtag stack-allocate-p)
+  (:ignore name stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:generator 4
diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp
index 4082bd1..5bdd76a 100644
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -241,6 +241,8 @@
 
 (define-primitive-object (value-cell :lowtag other-pointer-lowtag
                                      :widetag value-cell-header-widetag
+                                     ;; FIXME: We also have an explicit VOP
+                                     ;; for this. Is this needed as well?
                                      :alloc-trans make-value-cell)
   (value :set-trans value-cell-set
          :set-known (unsafe)
diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp
index 5f924b5..e2deca6 100644
--- a/src/compiler/generic/vm-ir2tran.lisp
+++ b/src/compiler/generic/vm-ir2tran.lisp
@@ -78,15 +78,19 @@
              name slot lowtag))))
   (aver (null args)))
 
-(defun emit-fixed-alloc (node block name words type lowtag result)
-  (vop fixed-alloc node block name words type lowtag result))
+(defun emit-fixed-alloc (node block name words type lowtag result lvar)
+  (let ((stack-allocate-p (and lvar (lvar-dynamic-extent lvar))))
+    (when stack-allocate-p
+      (vop current-stack-pointer node block
+           (ir2-lvar-stack-pointer (lvar-info lvar))))
+    (vop fixed-alloc node block name words type lowtag stack-allocate-p result)))
 
 (defoptimizer ir2-convert-fixed-allocation
               ((&rest args) node block name words type lowtag inits)
   (let* ((lvar (node-lvar node))
          (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
          (result (first locs)))
-    (emit-fixed-alloc node block name words type lowtag result)
+    (emit-fixed-alloc node block name words type lowtag result lvar)
     (emit-inits node block name result lowtag inits args)
     (move-lvar-result node block locs lvar)))
 
@@ -97,7 +101,7 @@
          (result (first locs)))
     (if (constant-lvar-p extra)
         (let ((words (+ (lvar-value extra) words)))
-          (emit-fixed-alloc node block name words type lowtag result))
+          (emit-fixed-alloc node block name words type lowtag result lvar))
         (vop var-alloc node block (lvar-tn node block extra) name words
              type lowtag result))
     (emit-inits node block name result lowtag inits args)
diff --git a/src/compiler/hppa/alloc.lisp b/src/compiler/hppa/alloc.lisp
index 008117d..779234f 100644
--- a/src/compiler/hppa/alloc.lisp
+++ b/src/compiler/hppa/alloc.lisp
@@ -158,8 +158,8 @@
 
 (define-vop (fixed-alloc)
   (:args)
-  (:info name words type lowtag)
-  (:ignore name)
+  (:info name words type lowtag stack-allocate-p)
+  (:ignore name stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:generator 4
diff --git a/src/compiler/mips/alloc.lisp b/src/compiler/mips/alloc.lisp
index 033f4c8..7b0c343 100644
--- a/src/compiler/mips/alloc.lisp
+++ b/src/compiler/mips/alloc.lisp
@@ -175,8 +175,8 @@
 
 (define-vop (fixed-alloc)
   (:args)
-  (:info name words type lowtag)
-  (:ignore name)
+  (:info name words type lowtag stack-allocate-p)
+  (:ignore name stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp
index f2aeb81..e3dd0fb 100644
--- a/src/compiler/ppc/alloc.lisp
+++ b/src/compiler/ppc/alloc.lisp
@@ -181,8 +181,8 @@
 
 (define-vop (fixed-alloc)
   (:args)
-  (:info name words type lowtag)
-  (:ignore name)
+  (:info name words type lowtag stack-allocate-p)
+  (:ignore name stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
diff --git a/src/compiler/sparc/alloc.lisp b/src/compiler/sparc/alloc.lisp
index aa4f8b8..51350be 100644
--- a/src/compiler/sparc/alloc.lisp
+++ b/src/compiler/sparc/alloc.lisp
@@ -173,8 +173,8 @@
 
 (define-vop (fixed-alloc)
   (:args)
-  (:info name words type lowtag)
-  (:ignore name)
+  (:info name words type lowtag stack-allocate-p)
+  (:ignore name stack-allocate-p)
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:generator 4
diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp
index c89b135..c7b7de2 100644
--- a/src/compiler/x86-64/alloc.lisp
+++ b/src/compiler/x86-64/alloc.lisp
@@ -11,7 +11,9 @@
 
 (in-package "SB!VM")
 
-;;;; 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))
@@ -248,13 +250,13 @@
 
 (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)
+     (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)
diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp
index f3cf5f9..59d47f5 100644
--- a/src/compiler/x86/alloc.lisp
+++ b/src/compiler/x86/alloc.lisp
@@ -11,7 +11,9 @@
 
 (in-package "SB!VM")
 
-;;;; 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))
@@ -278,7 +280,7 @@
 
 (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)
@@ -290,8 +292,10 @@
     ;; 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)))
+    (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"
@@ -302,7 +306,7 @@
           (aver (null type))
           (inst call (make-fixup dst :assembly-routine)))
         (pseudo-atomic
-         (allocation result (pad-data-block words) node)
+         (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)
diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 8579383..704a55d 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -138,6 +138,14 @@
       (declare (dynamic-extent #'f))
       (true #'f))))
 
+;;; CONS
+
+(defun-with-dx cons-on-stack (x)
+  (let ((cons (cons x x)))
+    (declare (dynamic-extent cons))
+    (true cons)
+    nil))
+
 ;;; with-spinlock should use DX and not cons
 
 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
@@ -176,6 +184,7 @@
   (assert-no-consing (test-let-var-subst2 17))
   (assert-no-consing (test-lvar-subst 11))
   (assert-no-consing (dx-value-cell 13))
+  (assert-no-consing (cons-on-stack 42))
   ;; Not strictly DX..
   (assert-no-consing (test-hash-table))
   #+sb-thread
diff --git a/version.lisp-expr b/version.lisp-expr
index d2a27eb..758220a 100644
--- 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".)
-"1.0.10.4"
+"1.0.10.5"