0.8.9.10:

	DYNAMIC-EXTENT &REST lists.
	... much as per CSR sbcl-devel 2004-03-29;
	... alter listify-rest-args VOPs on non-x86 to meet the new use
		(don't do anything yet with the DX parameter)
	... note concerns over stack manipulation in x86 DX allocation

	This version compiles and passes tests on x86 and alpha (modulo
	one unrelated bugfix, coming soon)

NEWS

@@ -2364,6 +2364,9 @@ changes in sbcl-0.8.9 relative to sbcl-0.8.8:
        the readtable currently in effect.
 
 changes in sbcl-0.8.10 relative to sbcl-0.8.9:
+  * [placeholder for DX summary]
+    ** user code with &REST lists declared dynamic-extent, under high
+       speed or space and low safety and debug optimization policy.
   * bug fix: compiler emitted division in optimized DEREF.  (thanks for
     the test case to Dave Roberts)
   * bug fix: multidimensional simple arrays loaded from FASLs had fill

TLA

@@ -19,6 +19,7 @@ Some of these already were used pretty consistently in CMU CL.
 Others not so much, but in sbcl-0.7.0 I put some effort into
 making them more consistent.
 	ARG	argument
+        DX	dynamic-extent
 	FUN	function
 	GC	garbage collect(ion)
 	N	new: number, as in e.g. N-PASSES or N-WORD-BITS

src/compiler/alpha/call.lisp

@@ -1104,7 +1104,9 @@ default-value-8
 (define-vop (listify-rest-args)
   (:args (context-arg :target context :scs (descriptor-reg))
 	 (count-arg :target count :scs (any-reg)))
-  (:arg-types * tagged-num)
+  (:info dx)
+  (:ignore dx)
+  (:arg-types * tagged-num (:constant t))
   (:temporary (:scs (any-reg) :from (:argument 0)) context)
   (:temporary (:scs (any-reg) :from (:argument 1)) count)
   (:temporary (:scs (descriptor-reg) :from :eval) temp dst)

src/compiler/fndb.lisp

@@ -1362,7 +1362,9 @@
 (defknown %cleanup-point () t)
 (defknown %special-bind (t t) t)
 (defknown %special-unbind (t) t)
-(defknown %listify-rest-args (t index) list (flushable))
+(defknown %dynamic-extent-start () t)
+(defknown %dynamic-extent-end () t)
+(defknown %listify-rest-args (t index t) list (flushable))
 (defknown %more-arg-context (t t) (values t index) (flushable))
 (defknown %more-arg (t index) t)
 (defknown %more-arg-values (t index index) * (flushable))

src/compiler/hppa/call.lisp

@@ -1,5 +1,15 @@
-(in-package "SB!VM")
+;;;; the VM definition of function call for the HPPA
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
 
+(in-package "SB!VM")
 
 ;;;; Interfaces to IR2 conversion:
 
@@ -1068,7 +1078,9 @@ default-value-8
 (define-vop (listify-rest-args)
   (:args (context-arg :target context :scs (descriptor-reg))
 	 (count-arg :target count :scs (any-reg)))
-  (:arg-types * tagged-num)
+  (:info dx)
+  (:ignore dx)
+  (:arg-types * tagged-num (:constant t))
   (:temporary (:scs (any-reg) :from (:argument 0)) context)
   (:temporary (:scs (any-reg) :from (:argument 1)) count)
   (:temporary (:scs (descriptor-reg) :from :eval) temp)

src/compiler/ir1tran-lambda.lisp

@@ -255,6 +255,24 @@
 				      (rest svars))))))
   (values))
 
+;;; FIXME: this is the interface of the CMUCL WITH-DYNAMIC-EXTENT
+;;; macro.  It is slightly confusing, in that START and BODY-START are
+;;; already-existing CTRANs (and FIXME: probably deserve a ONCE-ONLY),
+;;; whereas NEXT is a variable naming a CTRAN in the body.  -- CSR,
+;;; 2004-03-30.
+(defmacro with-dynamic-extent ((start body-start next kind) &body body)
+  (with-unique-names (cleanup next-ctran)
+    `(progn
+      (ctran-starts-block ,body-start)
+      (let ((,cleanup (make-cleanup :kind :dynamic-extent))
+	    (,next-ctran (make-ctran))
+	    (,next (make-ctran)))
+	(ir1-convert ,start ,next-ctran nil '(%dynamic-extent-start))
+	(setf (cleanup-mess-up ,cleanup) (ctran-use ,next-ctran))
+	(let ((*lexenv* (make-lexenv :cleanup ,cleanup)))
+	  (ir1-convert ,next-ctran ,next nil '(%cleanup-point))
+	  (locally ,@body))))))
+
 ;;; Create a lambda node out of some code, returning the result. The
 ;;; bindings are specified by the list of VAR structures VARS. We deal
 ;;; with adding the names to the LEXENV-VARS for the conversion. The
@@ -267,7 +285,7 @@
 ;;; the special binding code.
 ;;;
 ;;; We ignore any ARG-INFO in the VARS, trusting that someone else is
-;;; dealing with &nonsense.
+;;; dealing with &NONSENSE, except for &REST vars with DYNAMIC-EXTENT.
 ;;;
 ;;; AUX-VARS is a list of VAR structures for variables that are to be
 ;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated
@@ -291,7 +309,8 @@
                   :%source-name source-name
                   :%debug-name debug-name))
 	 (result-ctran (make-ctran))
-         (result-lvar (make-lvar)))
+         (result-lvar (make-lvar))
+	 (dx-rest nil))
 
     (awhen (lexenv-lambda *lexenv*)
       (push lambda (lambda-children it))
@@ -321,7 +340,12 @@
 		(t
                  (when note-lexical-bindings
                    (note-lexical-binding (leaf-source-name var)))
-		 (new-venv (cons (leaf-source-name var) var))))))
+		 (new-venv (cons (leaf-source-name var) var)))))
+	(let ((info (lambda-var-arg-info var)))
+	  (when (and info
+		     (eq (arg-info-kind info) :rest)
+		     (leaf-dynamic-extent var))
+	    (setq dx-rest t))))
 
       (let ((*lexenv* (make-lexenv :vars (new-venv)
 				   :lambda lambda
@@ -346,9 +370,14 @@
             (ctran-starts-block prebind-ctran)
             (link-node-to-previous-ctran bind prebind-ctran)
             (use-ctran bind postbind-ctran)
-            (ir1-convert-special-bindings postbind-ctran result-ctran result-lvar
-                                          body
-                                          aux-vars aux-vals (svars))))))
+	    (if dx-rest
+		(with-dynamic-extent (postbind-ctran result-ctran dx :rest)
+		  (ir1-convert-special-bindings dx result-ctran result-lvar
+						body aux-vars aux-vals
+						(svars)))
+		(ir1-convert-special-bindings postbind-ctran result-ctran
+					      result-lvar body
+					      aux-vars aux-vals (svars)))))))
 
     (link-blocks (component-head *current-component*) (node-block bind))
     (push lambda (component-new-functionals *current-component*))
@@ -514,7 +543,8 @@
       (arg-vars context-temp count-temp)
 
       (when rest
-	(arg-vals `(%listify-rest-args ,n-context ,n-count)))
+	(arg-vals `(%listify-rest-args
+		    ,n-context ,n-count ,(leaf-dynamic-extent rest))))
       (when morep
 	(arg-vals n-context)
 	(arg-vals n-count))

src/compiler/ir1tran.lisp

@@ -1104,6 +1104,38 @@
 	(setf (lambda-var-ignorep var) t)))))
   (values))
 
+(defun process-dx-decl (names vars)
+  (flet ((maybe-notify (control &rest args)
+	   (when (policy *lexenv* (> speed inhibit-warnings))
+	     (apply #'compiler-notify control args))))
+    (if (policy *lexenv* (= stack-allocate-dynamic-extent 3))
+	(dolist (name names)
+	  (cond
+	    ((symbolp name)
+	     (let* ((bound-var (find-in-bindings vars name))
+		    (var (or bound-var
+			     (lexenv-find name vars)
+			     (find-free-var name))))
+	       (etypecase var
+		 (leaf
+		  (if bound-var
+		      (setf (leaf-dynamic-extent var) t)
+		      (maybe-notify
+		       "ignoring DYNAMIC-EXTENT declaration for free ~S"
+		       name)))
+		 (cons
+		  (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+		 (heap-alien-info
+		  (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S"
+				  name)))))
+	    ((and (consp name)
+		  (eq (car name) 'function)
+		  (null (cddr name))
+		  (valid-function-name-p (cadr name)))
+	     (maybe-notify "ignoring DYNAMIC-EXTENT declaration for ~S" name))
+	    (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
+      (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))
+
 ;;; FIXME: This is non-ANSI, so the default should be T, or it should
 ;;; go away, I think.
 (defvar *suppress-values-declaration* nil
@@ -1146,10 +1178,7 @@
                        `(values ,@types)))))
           res))
        (dynamic-extent
-        (when (policy *lexenv* (> speed inhibit-warnings))
-          (compiler-notify
-           "compiler limitation: ~
-          ~%  There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
+	(process-dx-decl (cdr spec) vars)
         res)
        (t
         (unless (info :declaration :recognized (first spec))

src/compiler/ir2tran.lisp

@@ -1331,6 +1331,9 @@
 (defoptimizer (%special-unbind ir2-convert) ((var) node block)
   (vop unbind node block))
 
+(defoptimizer (%dynamic-extent-start ir2-convert) (() node block) node block)
+(defoptimizer (%dynamic-extent-end ir2-convert) (() node block) node block)
+
 ;;; ### It's not clear that this really belongs in this file, or
 ;;; should really be done this way, but this is the least violation of
 ;;; abstraction in the current setup. We don't want to wire

src/compiler/mips/call.lisp

@@ -1,5 +1,15 @@
-(in-package "SB!VM")
+;;;; the VM definition of function call for MIPS
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
 
+(in-package "SB!VM")
 
 ;;;; Interfaces to IR2 conversion:
 
@@ -1099,7 +1109,9 @@ default-value-8
 (define-vop (listify-rest-args)
   (:args (context-arg :target context :scs (descriptor-reg))
 	 (count-arg :target count :scs (any-reg)))
-  (:arg-types * tagged-num)
+  (:info dx)
+  (:ignore dx)
+  (:arg-types * tagged-num (:constant t))
   (:temporary (:scs (any-reg) :from (:argument 0)) context)
   (:temporary (:scs (any-reg) :from (:argument 1)) count)
   (:temporary (:scs (descriptor-reg) :from :eval) temp dst)

src/compiler/node.lisp

@@ -423,7 +423,8 @@
 (defstruct (cleanup (:copier nil))
   ;; the kind of thing that has to be cleaned up
   (kind (missing-arg)
-	:type (member :special-bind :catch :unwind-protect :block :tagbody))
+	:type (member :special-bind :catch :unwind-protect
+		      :block :tagbody :dynamic-extent))
   ;; the node that messes things up. This is the last node in the
   ;; non-messed-up environment. Null only temporarily. This could be
   ;; deleted due to unreachability.
@@ -593,6 +594,8 @@
   ;; true if there was ever a REF or SET node for this leaf. This may
   ;; be true when REFS and SETS are null, since code can be deleted.
   (ever-used nil :type boolean)
+  ;; is it declared dynamic-extent?
+  (dynamic-extent nil :type boolean)
   ;; some kind of info used by the back end
   (info nil))
 

src/compiler/physenvanal.lisp

@@ -364,7 +364,9 @@
 	       (code `(%funcall ,fun))))
 	    ((:block :tagbody)
 	     (dolist (nlx (cleanup-nlx-info cleanup))
-	       (code `(%lexical-exit-breakup ',nlx)))))))
+	       (code `(%lexical-exit-breakup ',nlx))))
+	    (:dynamic-extent
+	     (code `(%dynamic-extent-end))))))
 
       (when (code)
 	(aver (not (node-tail-p (block-last block1))))

src/compiler/policies.lisp

@@ -49,3 +49,10 @@
         3
         0)
   ("no" "maybe" "yes" "yes"))
+
+(define-optimization-quality stack-allocate-dynamic-extent
+    (if (and (> (max speed space) (max debug safety))
+	     (< safety 3))
+	3
+	0)
+  ("no" "maybe" "yes" "yes"))

src/compiler/ppc/call.lisp

@@ -1100,7 +1100,9 @@ default-value-8
 (define-vop (listify-rest-args)
   (:args (context-arg :target context :scs (descriptor-reg))
 	 (count-arg :target count :scs (any-reg)))
-  (:arg-types * tagged-num)
+  (:info dx)
+  (:ignore dx)
+  (:arg-types * tagged-num (:constant t))
   (:temporary (:scs (any-reg) :from (:argument 0)) context)
   (:temporary (:scs (any-reg) :from (:argument 1)) count)
   (:temporary (:scs (descriptor-reg) :from :eval) temp)

src/compiler/sparc/call.lisp

@@ -1073,7 +1073,9 @@ default-value-8
 (define-vop (listify-rest-args)
   (:args (context-arg :target context :scs (descriptor-reg))
 	 (count-arg :target count :scs (any-reg)))
-  (:arg-types * tagged-num)
+  (:info dx)
+  (:ignore dx)
+  (:arg-types * tagged-num (:constant t))
   (:temporary (:scs (any-reg) :from (:argument 0)) context)
   (:temporary (:scs (any-reg) :from (:argument 1)) count)
   (:temporary (:scs (descriptor-reg) :from :eval) temp)

src/compiler/x86/call.lisp

@@ -1265,7 +1265,8 @@
   (:policy :safe)
   (:args (context :scs (descriptor-reg) :target src)
 	 (count :scs (any-reg) :target ecx))
-  (:arg-types * tagged-num)
+  (:info *dynamic-extent*)
+  (:arg-types * tagged-num (:constant t))
   (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 0)) src)
   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
   (:temporary (:sc unsigned-reg :offset eax-offset) eax)
@@ -1283,7 +1284,7 @@
       (inst jecxz done)
       (inst lea dst (make-ea :dword :index ecx :scale 2))
       (pseudo-atomic
-       (allocation dst dst node)
+       (allocation dst dst node *dynamic-extent*)
        (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.