sbcl-0.8.14.11:

        * Merge DX sbcl-0-8-13-dx branch.
        * Out-of-line VALUES does not cons.
        * Forbid loading of initialization files in foreign.test.sh.

32 files changed, 525 insertions, 211 deletions

diff --git a/NEWS b/NEWS
index 54d76b009..095aec7da 100644
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,9 @@ changes in sbcl-0.8.15 relative to sbcl-0.8.14:
     Sean Champ and Raymond Toy)
   * bug fix: incorrect expansion of defgeneric that caused
     a style warning. (thanks for Zach Beane)
+  * on x86 compiler supports stack allocation of results of LIST and
+    LIST*, bound to variables, declared DYNAMIC-EXTENT. (based on
+    CMUCL implementation by Gerd Moellmann)
 
 changes in sbcl-0.8.14 relative to sbcl-0.8.13:
   * incompatible change: the internal functions
diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS
index 1f8746f14..b0c8f47fe 100644
--- a/OPTIMIZATIONS
+++ b/OPTIMIZATIONS
@@ -190,3 +190,44 @@ through TYPEP UNBOXED-ARRAY, within the compiler itself.
 rather than either constant-folding or manipulating NIL-VALUE or
 NULL-TN directly.
 --------------------------------------------------------------------------------
+#19
+  (let ((dx (if (foo)
+                (list x)
+                (list y z))))
+    (declare (dynamic-extent dx))
+    ...)
+
+DX is not allocated on stack.
+--------------------------------------------------------------------------------
+#20
+(defun-with-dx foo (x)
+  (flet ((make (x)
+           (let ((l (list nil nil)))
+             (setf (first l) x)
+             (setf (second l) (1- x))
+             l)))
+    (let ((l (make x)))
+      (declare (dynamic-extent l))
+      (mapc #'print l))))
+
+Result of MAKE is not stack allocated, which means that
+stack-allocation of structures is impossible.
+--------------------------------------------------------------------------------
+#21
+(defun-with-dx foo ()
+  (let ((dx (list (list 1 2) (list 3 4)
+    (declare (dynamic-extent dx))
+    ...)))))
+
+External list in DX is allocated on stack, but internal are not.
+--------------------------------------------------------------------------------
+#22
+IR2 does not perform unused code flushing.
+--------------------------------------------------------------------------------
+#23
+Python does not know that &REST lists are LISTs (and cannot derive it).
+--------------------------------------------------------------------------------
+#24
+a. Iterations on &REST lists, returning them as VALUES could be
+   rewritten with &MORE vectors.
+b. Implement local unknown-values mv-call (useful for fast type checking).
diff --git a/doc/manual/efficiency.texinfo b/doc/manual/efficiency.texinfo
index 4643f90a3..20ab991c8 100644
--- a/doc/manual/efficiency.texinfo
+++ b/doc/manual/efficiency.texinfo
@@ -162,15 +162,36 @@ it would not be in the following situation:
 because both the allocation of the @code{&rest} list and the variable
 binding are outside the scope of the @code{optimize} declaration.
 
-There are many cases when dynamic-extent declarations could be useful.
-At present, SBCL implements
+There are many cases when @code{dynamic-extent} declarations could be
+useful. At present, SBCL implements
 
-@itemize 
+@itemize
 
 @item
 Stack allocation of @code{&rest} lists, where these are declared
 @code{dynamic-extent}.
 
+@item
+Stack allocation of @code{list} and @code{list*}, whose result is
+bound to a variable, declared @code{dynamic-extent}, such as
+
+@lisp
+(let ((list (list 1 2 3)))
+  (declare (dynamic-extent list)
+  ...))
+@end lisp
+
+or
+
+@lisp
+(flet ((f (x)
+         (declare (dynamic-extent x))
+         ...))
+  ...
+  (f (list 1 2 3))
+  ...)
+@end lisp
+
 @end itemize
 
 Future plans include
diff --git a/make-host-2.sh b/make-host-2.sh
index c3595959e..6f7faefa6 100644
--- a/make-host-2.sh
+++ b/make-host-2.sh
@@ -70,7 +70,8 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
 	       ;; stuff (e.g. %DETECT-STACK-EXHAUSTION in sbcl-0.7.2).
 	       (safety 2)
 	       (space 1)
-	       (speed 2)))))
+	       (speed 2)
+               (sb!c::stack-allocate-dynamic-extent 3)))))
         (compile 'proclaim-target-optimization)
 	(defun in-target-cross-compilation-mode (fun)
 	  "Call FUN with everything set up appropriately for cross-compiling
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 28ee3c83d..2bbeed6e4 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -278,12 +278,15 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
                "MORE-ARG-CONTEXT" "MOVABLE" "MOVE" "MULTIPLE-CALL"
                "MULTIPLE-CALL-LOCAL" "MULTIPLE-CALL-NAMED"
                "MULTIPLE-CALL-VARIABLE"
-               "%%NIP-VALUES"
+               "%%NIP-DX" "%%NIP-VALUES"
                "NLX-ENTRY" "NLX-ENTRY-MULTIPLE"
+               "NODE-STACK-ALLOCATE-P"
                "NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START"
                "NOTE-THIS-LOCATION" "OPTIMIZER" "PACK-TRACE-TABLE"
                "PARSE-EVAL-WHEN-SITUATIONS"
-               "POLICY" "PREDICATE" "PRIMITIVE-TYPE" "PRIMITIVE-TYPE-OF"
+               "POLICY"
+               "%%POP-DX"
+               "PREDICATE" "PRIMITIVE-TYPE" "PRIMITIVE-TYPE-OF"
                "PRIMITIVE-TYPE-OR-LOSE" "PRIMITIVE-TYPE-VOP"
                "PRIMITIVE-TYPE-NAME" "PUSH-VALUES"
                "READ-PACKED-BIT-VECTOR" "READ-VAR-INTEGER" "READ-VAR-STRING"
diff --git a/src/code/eval.lisp b/src/code/eval.lisp
index 7b3764e51..24f0eee0b 100644
--- a/src/code/eval.lisp
+++ b/src/code/eval.lisp
@@ -245,6 +245,7 @@
 (defun values (&rest values)
   #!+sb-doc
   "Return all arguments, in order, as values."
+  (declare (dynamic-extent values))
   (values-list values))
 
 (defun values-list (list)
diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp
index 538853bf1..efbf2f251 100644
--- a/src/compiler/alpha/call.lisp
+++ b/src/compiler/alpha/call.lisp
@@ -1109,8 +1109,6 @@ default-value-8
 (define-vop (listify-rest-args)
   (:args (context-arg :target context :scs (descriptor-reg))
 	 (count-arg :target count :scs (any-reg)))
-  (: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)
diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index 7e6244a91..84c120d4f 100644
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -941,6 +941,11 @@
   (format t "v~D " (cont-num cont))
   (values))
 
+(defun print-lvar-stack (stack &optional (stream *standard-output*))
+  (loop for (lvar . rest) on stack
+        do (format stream "~:[u~;d~]v~D~@[ ~]"
+                   (lvar-dynamic-extent lvar) (cont-num lvar) rest)))
+
 ;;; Print out the nodes in BLOCK in a format oriented toward
 ;;; representing what the code does.
 (defun print-nodes (block)
@@ -953,8 +958,8 @@
 
     (pprint-newline :mandatory)
     (awhen (block-info block)
-      (format t "start stack:~{ v~D~}"
-              (mapcar #'cont-num (ir2-block-start-stack it)))
+      (format t "start stack: ")
+      (print-lvar-stack (ir2-block-start-stack it))
       (pprint-newline :mandatory))
     (do ((ctran (block-start block) (node-next (ctran-next ctran))))
         ((not ctran))
@@ -996,7 +1001,13 @@
            (print-lvar (return-result node))
            (print-leaf (return-lambda node)))
           (entry
-           (format t "entry ~S" (entry-exits node)))
+           (let ((cleanup (entry-cleanup node)))
+             (case (cleanup-kind cleanup)
+               ((:dynamic-extent)
+                (format t "entry DX~{ v~D~}"
+                        (mapcar #'cont-num (cleanup-info cleanup))))
+               (t
+                (format t "entry ~S" (entry-exits node))))))
           (exit
            (let ((value (exit-value node)))
              (cond (value
@@ -1015,8 +1026,8 @@
         (pprint-newline :mandatory)))
 
     (awhen (block-info block)
-      (format t "end stack:~{ v~D~}"
-              (mapcar #'cont-num (ir2-block-end-stack it)))
+      (format t "end stack: ")
+      (print-lvar-stack (ir2-block-end-stack it))
       (pprint-newline :mandatory))
     (let ((succ (block-succ block)))
       (format t "successors~{ c~D~}~%"
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 1f39e627d..8ab1e064b 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1363,9 +1363,7 @@
 (defknown %cleanup-point () t)
 (defknown %special-bind (t t) t)
 (defknown %special-unbind (t) t)
-(defknown %dynamic-extent-start () t)
-(defknown %dynamic-extent-end () t)
-(defknown %listify-rest-args (t index t) list (flushable))
+(defknown %listify-rest-args (t index) 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))
diff --git a/src/compiler/hppa/call.lisp b/src/compiler/hppa/call.lisp
index 58191b438..25303d433 100644
--- a/src/compiler/hppa/call.lisp
+++ b/src/compiler/hppa/call.lisp
@@ -1078,8 +1078,6 @@ default-value-8
 (define-vop (listify-rest-args)
   (:args (context-arg :target context :scs (descriptor-reg))
 	 (count-arg :target count :scs (any-reg)))
-  (: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)
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index b538652ed..55c8829e6 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -336,12 +336,16 @@
               ;; thus the control transfer is a non-local exit.
               (not (eq (block-home-lambda block)
                        (block-home-lambda next)))
-              ;; Stack analysis phase wants ENTRY to start a block.
+              ;; Stack analysis phase wants ENTRY to start a block...
               (entry-p (block-start-node next))
               (let ((last (block-last block)))
                 (and (valued-node-p last)
                      (awhen (node-lvar last)
-                       (consp (lvar-uses it))))))
+                       (or 
+                        ;; ... and a DX-allocator to end a block.
+                        (lvar-dynamic-extent it)
+                        ;; FIXME: This is a partial workaround for bug 303.
+                        (consp (lvar-uses it)))))))
              nil)
             (t
              (join-blocks block next)
@@ -1310,7 +1314,8 @@
              (dest (lvar-dest lvar)))
     (when (and
            ;; Think about (LET ((A ...)) (IF ... A ...)): two
-           ;; LVAR-USEs should not be met on one path.
+           ;; LVAR-USEs should not be met on one path. Another problem
+           ;; is with dynamic-extent.
            (eq (lvar-uses lvar) ref)
            (typecase dest
              ;; we should not change lifetime of unknown values lvars
@@ -1335,7 +1340,9 @@
            (eq (node-home-lambda ref)
                (lambda-home (lambda-var-home var))))
       (setf (node-derived-type ref) *wild-type*)
-      (substitute-lvar-uses lvar arg)
+      (substitute-lvar-uses lvar arg
+                            ;; Really it is (EQ (LVAR-USES LVAR) REF):
+                            t)
       (delete-lvar-use ref)
       (change-ref-leaf ref (find-constant nil))
       (delete-ref ref)
diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index c107a9382..651128d60 100644
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -255,25 +255,6 @@
 				      (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)
-  (declare (ignore kind))
-  (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
@@ -310,8 +291,7 @@
                   :%source-name source-name
                   :%debug-name debug-name))
 	 (result-ctran (make-ctran))
-         (result-lvar (make-lvar))
-	 (dx-rest nil))
+         (result-lvar (make-lvar)))
 
     (awhen (lexenv-lambda *lexenv*)
       (push lambda (lambda-children it))
@@ -341,12 +321,7 @@
 		(t
                  (when note-lexical-bindings
                    (note-lexical-binding (leaf-source-name 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))))
+		 (new-venv (cons (leaf-source-name var) var))))))
 
       (let ((*lexenv* (make-lexenv :vars (new-venv)
 				   :lambda lambda
@@ -371,14 +346,9 @@
             (ctran-starts-block prebind-ctran)
             (link-node-to-previous-ctran bind prebind-ctran)
             (use-ctran bind postbind-ctran)
-	    (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)))))))
+	    (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*))
@@ -545,7 +515,7 @@
 
       (when rest
 	(arg-vals `(%listify-rest-args
-		    ,n-context ,n-count ,(leaf-dynamic-extent rest))))
+		    ,n-context ,n-count)))
       (when morep
 	(arg-vals n-context)
 	(arg-vals n-count))
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 7600eebfa..4e4b031ab 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -164,16 +164,27 @@
   (values))
 
 ;;; Replace all uses of OLD with uses of NEW, where NEW has an
-;;; arbitary number of uses.
-(defun substitute-lvar-uses (new old)
+;;; arbitary number of uses. NEW is supposed to be "later" than OLD.
+(defun substitute-lvar-uses (new old propagate-dx)
   (declare (type lvar old)
-           (type (or lvar null) new))
-
-  (cond (new (do-uses (node old)
-               (%delete-lvar-use node)
-               (add-lvar-use node new))
-             (reoptimize-lvar new))
+           (type (or lvar null) new)
+           (type boolean propagate-dx))
+
+  (cond (new
+         (do-uses (node old)
+           (%delete-lvar-use node)
+           (add-lvar-use node new))
+         (reoptimize-lvar new)
+         (awhen (and propagate-dx (lvar-dynamic-extent old))
+           (setf (lvar-dynamic-extent old) nil)
+           (unless (lvar-dynamic-extent new)
+             (setf (lvar-dynamic-extent new) it)
+             (setf (cleanup-info it) (substitute new old (cleanup-info it)))))
+         (when (lvar-dynamic-extent new)
+           (do-uses (node new)
+             (node-ends-block node))))
         (t (flush-dest old)))
+
   (values))
 
 ;;;; block starting/creation
@@ -305,8 +316,9 @@
                     (when (and (basic-combination-p use)
                                (eq (basic-combination-kind use) :local))
                       (merges use))))
+                (substitute-lvar-uses lvar value
+                                      (and lvar (eq (lvar-uses lvar) node)))
                 (%delete-lvar-use node)
-                (substitute-lvar-uses lvar value)
                 (prog1
                     (unlink-node node)
                   (dolist (merge (merges))
@@ -342,6 +354,11 @@
 (defun node-dest (node)
   (awhen (node-lvar node) (lvar-dest it)))
 
+#!-sb-fluid (declaim (inline node-stack-allocate-p))
+(defun node-stack-allocate-p (node)
+  (awhen (node-lvar node)
+    (lvar-dynamic-extent it)))
+
 (declaim (inline block-to-be-deleted-p))
 (defun block-to-be-deleted-p (block)
   (or (block-delete-p block)
@@ -694,7 +711,7 @@
 ;;; end. The tricky thing is a special cleanup block; all its nodes
 ;;; have the same cleanup info, corresponding to the start, so the
 ;;; same approach returns safe result.
-(defun map-block-nlxes (fun block)
+(defun map-block-nlxes (fun block &optional dx-cleanup-fun)
   (loop for cleanup = (block-end-cleanup block)
         then (node-enclosing-cleanup (cleanup-mess-up cleanup))
         while cleanup
@@ -709,7 +726,10 @@
                 (aver (combination-p mess-up))
                 (let* ((arg-lvar (first (basic-combination-args mess-up)))
                        (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar)))))
-                (funcall fun nlx-info)))))))
+                (funcall fun nlx-info)))
+               ((:dynamic-extent)
+                (when dx-cleanup-fun
+                  (funcall dx-cleanup-fun cleanup)))))))
 
 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
 ;;; the head and tail which are set to T.
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index cf611d432..afa0fb692 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -623,6 +623,10 @@
 		 (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))))
 	    (if info-args
 		(emit-template call block template args r-refs info-args)
 		(emit-template call block template args r-refs))
@@ -1276,32 +1280,68 @@
 ;;; Reset the stack pointer to the start of the specified
 ;;; unknown-values lvar (discarding it and all values globs on top of
 ;;; it.)
-(defoptimizer (%pop-values ir2-convert) ((lvar) node block)
-  (let ((2lvar (lvar-info (lvar-value lvar))))
-    (aver (eq (ir2-lvar-kind 2lvar) :unknown))
-    (vop reset-stack-pointer node block
-	 (first (ir2-lvar-locs 2lvar)))))
-
-(defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved 
+(defoptimizer (%pop-values ir2-convert) ((%lvar) node block)
+  (let* ((lvar (lvar-value %lvar))
+         (2lvar (lvar-info lvar)))
+    (cond ((eq (ir2-lvar-kind 2lvar) :unknown)
+           (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))))
+          (t (bug "Trying to pop a not stack-allocated LVAR ~S."
+                  lvar)))))
+
+(locally (declare (optimize (debug 3)))
+(defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved
 						      &rest moved)
                                          node block)
-  (let (;; pointer immediately after the nipped block
-	(2after (lvar-info (lvar-value last-nipped)))
-	;; pointer to the first nipped word
-        (2first (lvar-info (lvar-value last-preserved)))
-
-        (moved-tns (loop for lvar-ref in moved
-                         for lvar = (lvar-value lvar-ref)
-                         for 2lvar = (lvar-info lvar)
-                         ;when 2lvar
-                         collect (first (ir2-lvar-locs 2lvar)))))
-    (aver (eq (ir2-lvar-kind 2after) :unknown))
+  (let* ( ;; pointer immediately after the nipped block
+         (after (lvar-value last-nipped))
+         (2after (lvar-info after))
+         ;; pointer to the first nipped word
+         (first (lvar-value last-preserved))
+         (2first (lvar-info first))
+
+         (moved-tns (loop for lvar-ref in moved
+                          for lvar = (lvar-value lvar-ref)
+                          for 2lvar = (lvar-info lvar)
+                                        ;when 2lvar
+                          collect (first (ir2-lvar-locs 2lvar)))))
+    (aver (or (eq (ir2-lvar-kind 2after) :unknown)
+              (lvar-dynamic-extent after)))
     (aver (eq (ir2-lvar-kind 2first) :unknown))
-    (vop* %%nip-values node block
-	 ((first (ir2-lvar-locs 2after))
-          (first (ir2-lvar-locs 2first))
-          (reference-tn-list moved-tns nil))
-         ((reference-tn-list moved-tns t)))))
+    (when *check-consistency*
+      ;; we cannot move stack-allocated DX objects
+      (dolist (moved-lvar moved)
+        (aver (eq (ir2-lvar-kind (lvar-info (lvar-value moved-lvar)))
+                  :unknown))))
+    (flet ((nip-aligned (nipped)
+             (vop* %%nip-values node block
+                   (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)))
+            (t
+             (bug "Trying to nip a not stack-allocated LVAR ~S." after)))))))
 
 ;;; Deliver the values TNs to LVAR using MOVE-LVAR-RESULT.
 (defoptimizer (values ir2-convert) ((&rest values) node block)
@@ -1354,9 +1394,6 @@
 (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
@@ -1562,11 +1599,16 @@
 		       (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))))
 		  (vop* ,name node block (refs) ((first res) nil)
 			(length args))
 		  (move-lvar-result node block res lvar)))))
   (def list)
   (def list*))
+
 
 ;;; Convert the code in a component into VOPs.
 (defun ir2-convert (component)
diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp
index 640b393a5..ec4945436 100644
--- a/src/compiler/knownfun.lisp
+++ b/src/compiler/knownfun.lisp
@@ -108,9 +108,12 @@
   (ltn-annotate nil :type (or function null))
   ;; If true, the special-case IR2 conversion method for this
   ;; function. This deals with funny functions, and anything else that
-  ;; can't be handled using the template mechanism. The Combination
+  ;; can't be handled using the template mechanism. The COMBINATION
   ;; node and the IR2-BLOCK are passed as arguments.
   (ir2-convert nil :type (or function null))
+  ;; If true, the function can stack-allocate the result. The
+  ;; COMBINATION node is passed as an argument.
+  (stack-allocate-result nil :type (or function null))
   ;; all the templates that could be used to translate this function
   ;; into IR2, sorted by increasing cost.
   (templates nil :type list)
diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 8ebe63ad4..107e9aee7 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -43,6 +43,45 @@
              (setf (car args) nil)))
   (values))
 
+(defun recognize-dynamic-extent-lvars (call fun)
+  (declare (type combination call) (type clambda fun))
+  (loop for arg in (basic-combination-args call)
+        and var in (lambda-vars fun)
+        when (and (lambda-var-dynamic-extent var)
+                  (not (lvar-dynamic-extent arg)))
+        collect arg into dx-lvars
+        and do (let ((use (lvar-uses arg)))
+                 ;; Stack analysis wants DX value generators to end
+                 ;; their blocks. Uses of mupltiple used LVARs already
+                 ;; end their blocks, so we just need to process
+                 ;; used-once LVARs.
+                 (when (node-p use)
+                   (node-ends-block use)))
+        finally (when dx-lvars
+                  (binding* ((before-ctran (node-prev call))
+                             (nil (ensure-block-start before-ctran))
+                             (block (ctran-block before-ctran))
+                             (new-call-ctran (make-ctran :kind :inside-block
+                                                         :next call
+                                                         :block block))
+                             (entry (with-ir1-environment-from-node call
+                                      (make-entry :prev before-ctran
+                                                  :next new-call-ctran)))
+                             (cleanup (make-cleanup :kind :dynamic-extent
+                                                    :mess-up entry
+                                                    :info dx-lvars)))
+                    (setf (node-prev call) new-call-ctran)
+                    (setf (ctran-next before-ctran) entry)
+                    (setf (ctran-use new-call-ctran) entry)
+                    (setf (entry-cleanup entry) cleanup)
+                    (setf (node-lexenv call)
+                          (make-lexenv :default (node-lexenv call)
+                                       :cleanup cleanup))
+                    (push entry (lambda-entries (node-home-lambda entry)))
+                    (dolist (lvar dx-lvars)
+                      (setf (lvar-dynamic-extent lvar) cleanup)))))
+  (values))
+
 ;;; This function handles merging the tail sets if CALL is potentially
 ;;; tail-recursive, and is a call to a function with a different
 ;;; TAIL-SET than CALL's FUN. This must be called whenever we alter
@@ -92,6 +131,7 @@
       (when arg
         (flush-lvar-externally-checkable-type arg))))
   (pushnew fun (lambda-calls-or-closes (node-home-lambda call)))
+  (recognize-dynamic-extent-lvars call fun)
   (merge-tail-sets call fun)
   (change-ref-leaf ref fun)
   (values))
@@ -846,7 +886,8 @@
         ;; FIXME: Replace the call with unsafe CAST. -- APD, 2003-01-26
         (do-uses (use result)
           (derive-node-type use call-type)))
-      (substitute-lvar-uses lvar result)))
+      (substitute-lvar-uses lvar result
+                            (and lvar (eq (lvar-uses lvar) call)))))
   (values))
 
 ;;; We are converting FUN to be a LET when the call is in a non-tail
diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index bbdb87aa7..9dce8b504 100644
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -98,8 +98,12 @@
     (cond
      ((lvar-delayed-leaf lvar)
       (setf (ir2-lvar-kind info) :delayed))
-     (t (setf (ir2-lvar-locs info)
-              (list (make-normal-tn (ir2-lvar-primitive-type info)))))))
+     (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)))))))
   (ltn-annotate-casts lvar)
   (values))
 
@@ -118,6 +122,7 @@
 ;;; reference, otherwise we annotate for a single value.
 (defun annotate-fun-lvar (lvar &optional (delay t))
   (declare (type lvar lvar))
+  (aver (not (lvar-dynamic-extent lvar)))
   (let* ((tn-ptype (primitive-type (lvar-type lvar)))
 	 (info (make-ir2-lvar tn-ptype)))
     (setf (lvar-info lvar) info)
@@ -195,6 +200,7 @@
 (defun annotate-unknown-values-lvar (lvar)
   (declare (type lvar lvar))
 
+  (aver (not (lvar-dynamic-extent lvar)))
   (let ((2lvar (make-ir2-lvar nil)))
     (setf (ir2-lvar-kind 2lvar) :unknown)
     (setf (ir2-lvar-locs 2lvar) (make-unknown-values-locations))
@@ -219,6 +225,7 @@
 ;;; specified primitive TYPES.
 (defun annotate-fixed-values-lvar (lvar types)
   (declare (type lvar lvar) (list types))
+  (aver (not (lvar-dynamic-extent lvar)))   ; XXX
   (let ((res (make-ir2-lvar nil)))
     (setf (ir2-lvar-locs res) (mapcar #'make-normal-tn types))
     (setf (lvar-info lvar) res))
diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index 43786213c..7d8bab0ff 100644
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -508,7 +508,8 @@
 	    ,(parse-deftransform lambda-list body n-args
 				 `(return-from ,name nil))))
 	,@(when (consp what)
-	    `((setf (,(symbolicate "FUN-INFO-" (second what))
+	    `((setf (,(let ((*package* (symbol-package 'sb!c::fun-info)))
+                        (symbolicate "FUN-INFO-" (second what)))
 		     (fun-info-or-lose ',(first what)))
 		    #',name)))))))
 
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 33637bfe4..77daf4dbf 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -398,7 +398,8 @@
     (maybe-mumble "control ")
     (control-analyze component #'make-ir2-block)
 
-    (when (ir2-component-values-receivers (component-info component))
+    (when (or (ir2-component-values-receivers (component-info component))
+              (component-dx-lvars component))
       (maybe-mumble "stack ")
       (stack-analyze component)
       ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by
diff --git a/src/compiler/mips/call.lisp b/src/compiler/mips/call.lisp
index d3d11efa2..3fe73f7ff 100644
--- a/src/compiler/mips/call.lisp
+++ b/src/compiler/mips/call.lisp
@@ -1109,8 +1109,6 @@ default-value-8
 (define-vop (listify-rest-args)
   (:args (context-arg :target context :scs (descriptor-reg))
 	 (count-arg :target count :scs (any-reg)))
-  (: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)
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index 24243aab3..d9ff1ebae 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -76,6 +76,8 @@
   ;; Cached type which is checked by DEST. If NIL, then this must be
   ;; recomputed: see LVAR-EXTERNALLY-CHECKABLE-TYPE.
   (%externally-checkable-type nil :type (or null ctype))
+  ;; if the LVAR value is DYNAMIC-EXTENT, CLEANUP protecting it.
+  (dynamic-extent nil :type (or null cleanup))
   ;; something or other that the back end annotates this lvar with
   (info nil))
 
@@ -374,7 +376,9 @@
   ;; from COMPONENT-LAMBDAS.
   (reanalyze-functionals nil :type list)
   (delete-blocks nil :type list)
-  (nlx-info-generated-p nil :type boolean))
+  (nlx-info-generated-p nil :type boolean)
+  ;; this is filled by physical environment analysis
+  (dx-lvars nil :type list))
 (defprinter (component :identity t)
   name
   #!+sb-show id
@@ -430,13 +434,21 @@
   ;; non-messed-up environment. Null only temporarily. This could be
   ;; deleted due to unreachability.
   (mess-up nil :type (or node null))
-  ;; a list of all the NLX-INFO structures whose NLX-INFO-CLEANUP is
-  ;; this cleanup. This is filled in by physical environment analysis.
-  (nlx-info nil :type list))
+  ;; For all kinds, except :DYNAMIC-EXTENT: a list of all the NLX-INFO
+  ;; structures whose NLX-INFO-CLEANUP is this cleanup. This is filled
+  ;; in by physical environment analysis.
+  ;;
+  ;; For :DYNAMIC-EXTENT: a list of all DX LVARs, preserved by this
+  ;; cleanup. This is filled when the cleanup is created (now by
+  ;; locall call analysis) and is rechecked by physical environment
+  ;; analysis.
+  (info nil :type list))
 (defprinter (cleanup :identity t)
   kind
   mess-up
-  (nlx-info :test nlx-info))
+  (info :test info))
+(defmacro cleanup-nlx-info (cleanup)
+  `(cleanup-info ,cleanup))
 
 ;;; A PHYSENV represents the result of physical environment analysis.
 ;;;
diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index 022442eee..037060dc3 100644
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -38,6 +38,7 @@
 	(component-lambdas component))
 
   (find-non-local-exits component)
+  (recheck-dynamic-extent-lvars component)
   (find-cleanup-points component)
   (tail-annotate component)
 
@@ -327,6 +328,28 @@
 	      (note-non-local-exit target-physenv exit))))))
   (values))
 
+;;;; final decision on stack allocation of dynamic-extent structores
+(defun recheck-dynamic-extent-lvars (component)
+  (declare (type component component))
+  (dolist (lambda (component-lambdas component))
+    (loop for entry in (lambda-entries lambda)
+            for cleanup = (entry-cleanup entry)
+            do (when (eq (cleanup-kind cleanup) :dynamic-extent)
+                 (collect ((real-dx-lvars))
+                   (loop for lvar in (cleanup-info cleanup)
+                         do (let ((use (lvar-uses lvar)))
+                              (if (and (combination-p use)
+                                       (eq (basic-combination-kind use) :known)
+                                       (awhen (fun-info-stack-allocate-result
+                                               (basic-combination-fun-info use))
+                                         (funcall it use)))
+                                  (real-dx-lvars lvar)
+                                  (setf (lvar-dynamic-extent lvar) nil))))
+                   (setf (cleanup-info cleanup) (real-dx-lvars))
+                   (setf (component-dx-lvars component)
+                         (append (real-dx-lvars) (component-dx-lvars component)))))))
+  (values))
+
 ;;;; cleanup emission
 
 ;;; Zoom up the cleanup nesting until we hit CLEANUP1, accumulating
@@ -370,7 +393,8 @@
 	     (dolist (nlx (cleanup-nlx-info cleanup))
 	       (code `(%lexical-exit-breakup ',nlx))))
 	    (:dynamic-extent
-	     (code `(%dynamic-extent-end))))))
+	     (when (not (null (cleanup-info cleanup)))
+               (code `(%cleanup-point)))))))
 
       (when (code)
 	(aver (not (node-tail-p (block-last block1))))
diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp
index 0a19d7284..3e40b5262 100644
--- a/src/compiler/ppc/call.lisp
+++ b/src/compiler/ppc/call.lisp
@@ -1100,8 +1100,6 @@ default-value-8
 (define-vop (listify-rest-args)
   (:args (context-arg :target context :scs (descriptor-reg))
 	 (count-arg :target count :scs (any-reg)))
-  (: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)
diff --git a/src/compiler/sparc/call.lisp b/src/compiler/sparc/call.lisp
index 4fdc31f57..2c8ecf515 100644
--- a/src/compiler/sparc/call.lisp
+++ b/src/compiler/sparc/call.lisp
@@ -1073,8 +1073,6 @@ default-value-8
 (define-vop (listify-rest-args)
   (:args (context-arg :target context :scs (descriptor-reg))
 	 (count-arg :target count :scs (any-reg)))
-  (: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)
diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp
index 121f98b64..fccf4f8a8 100644
--- a/src/compiler/stack.lisp
+++ b/src/compiler/stack.lisp
@@ -1,7 +1,10 @@
 ;;;; This file implements the stack analysis phase in the compiler. We
-;;;; do a graph walk to determine which unknown-values lvars are on
-;;;; the stack at each point in the program, and then we insert
-;;;; cleanup code to remove unused values.
+;;;; analyse lifetime of dynamically allocated object packets on stack
+;;;; and insert cleanups where necessary.
+;;;;
+;;;; Currently there are two kinds of interesting stack packets: UVLs,
+;;;; whose use and destination lie in different blocks, and LVARs of
+;;;; constructors of dynamic-extent objects.
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
@@ -29,14 +32,15 @@
 	  (when (eq node last-pop)
 	    (setq saw-last t))
 
-	  (when lvar
-            (let ((dest (lvar-dest lvar))
-                  (2lvar (lvar-info lvar)))
-              (when (and (not (eq (node-block dest) block))
-                         2lvar
-                         (eq (ir2-lvar-kind 2lvar) :unknown))
-                (aver (or saw-last (not last-pop)))
-                (pushed lvar))))))
+	  (when (and lvar
+                     (or (lvar-dynamic-extent lvar)
+                         (let ((dest (lvar-dest lvar))
+                               (2lvar (lvar-info lvar)))
+                           (and (not (eq (node-block dest) block))
+                                2lvar
+                                (eq (ir2-lvar-kind 2lvar) :unknown)))))
+            (aver (or saw-last (not last-pop)))
+            (pushed lvar))))
 
       (setf (ir2-block-pushed 2block) (pushed))))
   (values))
@@ -86,7 +90,25 @@
                                               nle-start-stack)))
                          (setq new-end (merge-uvl-live-sets
                                         new-end next-stack))))
-                     block)
+                     block
+                     (lambda (dx-cleanup)
+                       (dolist (lvar (cleanup-info dx-cleanup))
+                         (let* ((generator (lvar-use lvar))
+                                (block (node-block generator))
+                                (2block (block-info block)))
+                           (aver (eq generator (block-last block)))
+                           ;; DX objects, living in the LVAR, are
+                           ;; alive in the environment, protected by
+                           ;; the CLEANUP. We also cannot move them
+                           ;; (because, in general, we cannot track
+                           ;; all references to them). Therefore,
+                           ;; everything, allocated deeper than a DX
+                           ;; object, should be kept alive until the
+                           ;; object is deallocated.
+                           (setq new-end (merge-uvl-live-sets
+                                          new-end (ir2-block-end-stack 2block)))
+                           (setq new-end (merge-uvl-live-sets
+                                          new-end (ir2-block-pushed 2block)))))))
 
     (setf (ir2-block-end-stack 2block) new-end)
 
@@ -249,33 +271,37 @@
 ;;;; stack analysis
 
 ;;; Return a list of all the blocks containing genuine uses of one of
-;;; the RECEIVERS. Exits are excluded, since they don't drop through
-;;; to the receiver.
-(defun find-values-generators (receivers)
-  (declare (list receivers))
+;;; the RECEIVERS (blocks) and DX-LVARS. Exits are excluded, since
+;;; they don't drop through to the receiver.
+(defun find-pushing-blocks (receivers dx-lvars)
+  (declare (list receivers dx-lvars))
   (collect ((res nil adjoin))
     (dolist (rec receivers)
       (dolist (pop (ir2-block-popped (block-info rec)))
 	(do-uses (use pop)
 	  (unless (exit-p use)
 	    (res (node-block use))))))
+    (dolist (dx-lvar dx-lvars)
+      (do-uses (use dx-lvar)
+        (res (node-block use))))
     (res)))
 
-;;; Analyze the use of unknown-values lvars in COMPONENT, inserting
-;;; cleanup code to discard values that are generated but never
-;;; received. This phase doesn't need to be run when Values-Receivers
-;;; is null, i.e. there are no unknown-values lvars used across block
-;;; boundaries.
+;;; Analyze the use of unknown-values and DX lvars in COMPONENT,
+;;; inserting cleanup code to discard values that are generated but
+;;; never received. This phase doesn't need to be run when
+;;; Values-Receivers and Dx-Lvars are null, i.e. there are no
+;;; unknown-values lvars used across block boundaries and no DX LVARs.
 (defun stack-analyze (component)
   (declare (type component component))
   (let* ((2comp (component-info component))
 	 (receivers (ir2-component-values-receivers 2comp))
-	 (generators (find-values-generators receivers)))
+	 (generators (find-pushing-blocks receivers
+                                          (component-dx-lvars component))))
 
     (dolist (block generators)
       (find-pushed-lvars block))
 
-    ;;; Compute sets of live UVLs
+    ;;; Compute sets of live UVLs and DX LVARs
     (loop for did-something = nil
           do (do-blocks-backwards (block component)
                (when (update-uvl-live-sets block)
diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp
index 1d2c031ac..4570b36c8 100644
--- a/src/compiler/vop.lisp
+++ b/src/compiler/vop.lisp
@@ -214,7 +214,14 @@
   ;; since type checking is the responsibility of the values receiver,
   ;; these TNs primitive type is only based on the proven type
   ;; information.
-  (locs nil :type list))
+  (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
diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp
index a0ec28b41..1278d10e5 100644
--- a/src/compiler/x86/alloc.lisp
+++ b/src/compiler/x86/alloc.lisp
@@ -12,6 +12,10 @@
 (in-package "SB!VM")
 
 ;;;; 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,8 @@
 		     (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)
diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp
index 42c8c85ca..00e4572e6 100644
--- a/src/compiler/x86/call.lisp
+++ b/src/compiler/x86/call.lisp
@@ -1260,13 +1260,15 @@
 
 
 ;;; 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)
   (:args (context :scs (descriptor-reg) :target src)
 	 (count :scs (any-reg) :target ecx))
-  (:info *dynamic-extent*)
-  (:arg-types * tagged-num (:constant t))
+  (:arg-types * tagged-num)
   (: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)
@@ -1276,15 +1278,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 ecx 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 :dword :index ecx :scale 2))
-      (pseudo-atomic
-       (allocation dst dst node *dynamic-extent*)
+      (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/macros.lisp b/src/compiler/x86/macros.lisp
index 028d6b71f..a05440431 100644
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -313,79 +313,78 @@
 ;;; does not matter whether a signal occurs during construction of a
 ;;; dynamic-extent object, as the half-finished construction of the
 ;;; object will not cause any difficulty.  We can therefore elide 
-(defvar *dynamic-extent* nil)
+(defmacro maybe-pseudo-atomic (really-p &body forms)
+  `(if ,really-p
+       (progn ,@forms)
+       (pseudo-atomic ,@forms)))
 
 #!+sb-thread
 (defmacro pseudo-atomic (&rest forms)
   (with-unique-names (label)
-    `(if *dynamic-extent* ; I will burn in hell
-         (progn ,@forms)
-         (let ((,label (gen-label)))
-	   (inst fs-segment-prefix)
-	   (inst mov (make-ea :byte 
-			      :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
-	   (inst fs-segment-prefix)
-	   (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1)
-	   ,@forms
-	   (inst fs-segment-prefix)
-	   (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0)
-	   (inst fs-segment-prefix)
-	   (inst cmp (make-ea :byte
-			      :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
-	   (inst jmp :eq ,label)
-	   ;; if PAI was set, interrupts were disabled at the same
-	   ;; time using the process signal mask.
-	   (inst break pending-interrupt-trap)
-	   (emit-label ,label)))))
+    `(let ((,label (gen-label)))
+       (inst fs-segment-prefix)
+       (inst mov (make-ea :byte
+                          :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
+       (inst fs-segment-prefix)
+       (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1)
+       ,@forms
+       (inst fs-segment-prefix)
+       (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0)
+       (inst fs-segment-prefix)
+       (inst cmp (make-ea :byte
+                          :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
+       (inst jmp :eq ,label)
+       ;; if PAI was set, interrupts were disabled at the same
+       ;; time using the process signal mask.
+       (inst break pending-interrupt-trap)
+       (emit-label ,label))))
 
 #!-sb-thread
 (defmacro pseudo-atomic (&rest forms)
   (with-unique-names (label)
-    `(if *dynamic-extent*
-         (progn ,@forms)
-         (let ((,label (gen-label)))
-	   ;; FIXME: The MAKE-EA noise should become a MACROLET macro
-	   ;; or something. (perhaps SVLB, for static variable low
-	   ;; byte)
-	   (inst mov (make-ea :byte :disp (+ nil-value
-					     (static-symbol-offset
-					      '*pseudo-atomic-interrupted*)
-					     (ash symbol-value-slot word-shift)
-					     ;; FIXME: Use mask, not minus, to
-					     ;; take out type bits.
-					     (- other-pointer-lowtag)))
-		 0)
-	   (inst mov (make-ea :byte :disp (+ nil-value
-					     (static-symbol-offset
-					      '*pseudo-atomic-atomic*)
-					     (ash symbol-value-slot word-shift)
-					     (- other-pointer-lowtag)))
-		 (fixnumize 1))
-	   ,@forms
-	   (inst mov (make-ea :byte :disp (+ nil-value
-					     (static-symbol-offset
-					      '*pseudo-atomic-atomic*)
-					     (ash symbol-value-slot word-shift)
-					     (- other-pointer-lowtag)))
-		 0)
-	   ;; KLUDGE: Is there any requirement for interrupts to be
-	   ;; handled in order? It seems as though an interrupt coming
-	   ;; in at this point will be executed before any pending
-	   ;; interrupts.  Or do incoming interrupts check to see
-	   ;; whether any interrupts are pending? I wish I could find
-	   ;; the documentation for pseudo-atomics.. -- WHN 19991130
-	   (inst cmp (make-ea :byte
-			      :disp (+ nil-value
-				       (static-symbol-offset
-					'*pseudo-atomic-interrupted*)
-				       (ash symbol-value-slot word-shift)
-				       (- other-pointer-lowtag)))
-		 0)
-	   (inst jmp :eq ,label)
-	   ;; if PAI was set, interrupts were disabled at the same
-	   ;; time using the process signal mask.
-	   (inst break pending-interrupt-trap)
-	   (emit-label ,label)))))
+    `(let ((,label (gen-label)))
+       ;; FIXME: The MAKE-EA noise should become a MACROLET macro
+       ;; or something. (perhaps SVLB, for static variable low
+       ;; byte)
+       (inst mov (make-ea :byte :disp (+ nil-value
+                                         (static-symbol-offset
+                                          '*pseudo-atomic-interrupted*)
+                                         (ash symbol-value-slot word-shift)
+                                         ;; FIXME: Use mask, not minus, to
+                                         ;; take out type bits.
+                                         (- other-pointer-lowtag)))
+             0)
+       (inst mov (make-ea :byte :disp (+ nil-value
+                                         (static-symbol-offset
+                                          '*pseudo-atomic-atomic*)
+                                         (ash symbol-value-slot word-shift)
+                                         (- other-pointer-lowtag)))
+             (fixnumize 1))
+       ,@forms
+       (inst mov (make-ea :byte :disp (+ nil-value
+                                         (static-symbol-offset
+                                          '*pseudo-atomic-atomic*)
+                                         (ash symbol-value-slot word-shift)
+                                         (- other-pointer-lowtag)))
+             0)
+       ;; KLUDGE: Is there any requirement for interrupts to be
+       ;; handled in order? It seems as though an interrupt coming
+       ;; in at this point will be executed before any pending
+       ;; interrupts.  Or do incoming interrupts check to see
+       ;; whether any interrupts are pending? I wish I could find
+       ;; the documentation for pseudo-atomics.. -- WHN 19991130
+       (inst cmp (make-ea :byte
+                          :disp (+ nil-value
+                                   (static-symbol-offset
+                                    '*pseudo-atomic-interrupted*)
+                                   (ash symbol-value-slot word-shift)
+                                   (- other-pointer-lowtag)))
+             0)
+       (inst jmp :eq ,label)
+       ;; if PAI was set, interrupts were disabled at the same
+       ;; time using the process signal mask.
+       (inst break pending-interrupt-trap)
+       (emit-label ,label))))
 
 ;;;; indexed references
 
diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 339759dc1..5bdd4ad95 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -11,13 +11,19 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
-;;; &REST lists
+(setq sb-c::*check-consistency* t)
+
 (defmacro defun-with-dx (name arglist &body body)
   `(locally
      (declare (optimize sb-c::stack-allocate-dynamic-extent))
      (defun ,name ,arglist
        ,@body)))
 
+(declaim (notinline opaque-identity))
+(defun opaque-identity (x)
+  x)
+
+;;; &REST lists
 (defun-with-dx dxlength (&rest rest)
   (declare (dynamic-extent rest))
   (length rest))
@@ -35,5 +41,76 @@
   (callee rest))
 
 (assert (= (dxcaller 1 2 3 4 5 6 7) 22))
+
+;;; %NIP-VALUES
+(defun-with-dx test-nip-values ()
+  (flet ((bar (x &rest y)
+           (declare (dynamic-extent y))
+           (if (> x 0)
+               (values x (length y))
+               (values (car y)))))
+    (multiple-value-call #'values
+      (bar 1 2 3 4 5 6)
+      (bar -1 'a 'b))))
+
+(assert (equal (multiple-value-list (test-nip-values)) '(1 5 a)))
+
+;;; LET-variable substitution
+(defun-with-dx test-let-var-subst1 (x)
+  (let ((y (list x (1- x))))
+    (opaque-identity :foo)
+    (let ((z (the list y)))
+      (declare (dynamic-extent z))
+      (length z))))
+(assert (eql (test-let-var-subst1 17) 2))
+
+(defun-with-dx test-let-var-subst2 (x)
+  (let ((y (list x (1- x))))
+    (declare (dynamic-extent y))
+    (opaque-identity :foo)
+    (let ((z (the list y)))
+      (length z))))
+(assert (eql (test-let-var-subst2 17) 2))
+
+;;; DX propagation through LET-return.
+(defun-with-dx test-lvar-subst (x)
+  (let ((y (list x (1- x))))
+    (declare (dynamic-extent y))
+    (second (let ((z (the list y)))
+              (opaque-identity :foo)
+              z))))
+(assert (eql (test-lvar-subst 11) 10))
+
+;;; this code is incorrect, but the compiler should not fail
+(defun-with-dx test-let-var-subst-incorrect (x)
+  (let ((y (list x (1- x))))
+    (opaque-identity :foo)
+    (let ((z (the list y)))
+      (declare (dynamic-extent z))
+      (opaque-identity :bar)
+      z)))
+
+(defmacro assert-no-consing (form &optional times)
+  `(%assert-no-consing (lambda () ,form ,times)))
+(defun %assert-no-consing (thunk &optional times)
+  (let ((before (get-bytes-consed))
+        (times (or times 10000)))
+    (declare (type (integer 1 *) times))
+    (dotimes (i times)
+      (funcall thunk))
+    (assert (< (- (get-bytes-consed) before) times))))
+
+#+x86
+(progn
+  (assert-no-consing (dxlength 1 2 3))
+  (assert-no-consing (dxlength t t t t t t))
+  (assert-no-consing (dxlength))
+  (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
+  (assert-no-consing (test-nip-values))
+  (assert-no-consing (test-let-var-subst1 17))
+  (assert-no-consing (test-let-var-subst2 17))
+  (assert-no-consing (test-lvar-subst 11))
+  )
+
 
 (sb-ext:quit :unix-status 104)
\ No newline at end of file
diff --git a/tests/foreign.test.sh b/tests/foreign.test.sh
index ac7ebcc29..593412a68 100644
--- a/tests/foreign.test.sh
+++ b/tests/foreign.test.sh
@@ -83,7 +83,7 @@ if [ $? = 22 ]; then
     exit $PUNT # success -- linkage-table not available
 fi
 
-$SBCL_ALLOWING_CORE --core $testfilestem.core --load $testfilestem.testlisp
+$SBCL_ALLOWING_CORE --core $testfilestem.core --sysinit /dev/null --userinit /dev/null --load $testfilestem.testlisp
 if [ $? != 52 ]; then
     rm $testfilestem.*
     echo test failed: $?
diff --git a/version.lisp-expr b/version.lisp-expr
index 3da2fce9e..6b47397b2 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".)
-"0.8.14.10"
+"0.8.14.11"